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)' ) ' Test the SLATEC library.' 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 continue 60 continue ! 70 continue ! 80 continue ! 90 continue ! 100 continue ! ! Report result. ! 110 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, ''',''', A1, ''',', & 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, & ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of CCHK13. ! '******' ) end subroutine CCHK22 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NKB, KB, NALF, ALF, NBET, BET, NINC, INC, NMAX, INCMAX, & !*****************************************************************************80 ! !! CCHK22 is a quick check for CHEMV, CHBMV, CHPMV. ! !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for CHEMV, CHBMV and CHPMV. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CHBMV, CHEMV, CHPMV, CMAKE2, CMVCH, LCE, LCERES, ! NUMXER !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CCHK22 ! .. 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, IK, IN, INCX, INCXS, INCY, & INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, & N, NARGS, NC, NERR, NK, NS LOGICAL BANDED, FTL, FULL, NULL, PACKED, RESET CHARACTER*1 UPLO, UPLOS ! .. Local Arrays .. CHARACTER*2 ICH ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LCE, LCERES ! .. External Subroutines .. EXTERNAL LCE, LCERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL CHBMV, CHEMV, CHPMV, CMAKE2, CMVCH ! .. Data statements .. INTRINSIC ABS, MAX !***FIRST EXECUTABLE STATEMENT CCHK22 DATA ICH/'UL'/ FULL = SNAME( 3: 3 ) == 'E' BANDED = SNAME( 3: 3 ) == 'B' ! Define the number of arguments. PACKED = SNAME( 3: 3 ) == 'P' if ( FULL ) then NARGS = 10 else if ( BANDED ) then NARGS = 11 else if ( PACKED ) then NARGS = 9 end if NC = 0 RESET = .TRUE. ERRMAX = RZERO DO 110 IN = 1, NIDIM N = IDIM( IN ) if ( BANDED ) then NK = NKB else NK = 1 end if DO 100 IK = 1, NK if ( BANDED ) then K = KB( IK ) else K = N - 1 ! Set LDA to 1 more than minimum value if room. end if if ( BANDED ) then LDA = K + 1 else LDA = N end if if ( LDA < NMAX ) & ! ! Skip tests if not enough room. ! LDA = LDA + 1 if ( LDA > NMAX ) & GO TO 100 if ( PACKED ) then LAA = ( N*( N + 1 ) )/2 else LAA = LDA*N end if ! NULL = N <= 0 DO 90 IC = 1, 2 ! ! Generate the matrix A. ! UPLO = ICH( IC: IC ) TRANSL = ZERO call CMAKE2( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA, & ! LDA, K, K, RESET, TRANSL ) DO 80 IX = 1, NINC INCX = INC( IX ) ! ! Generate the vector X. ! LX = ABS( INCX )*N TRANSL = HALF call CMAKE2( 'GE', ' ', ' ', 1, N, X, 1, XX, & ABS( INCX ), 0, N - 1, RESET, TRANSL ) if ( N > 1 ) then X( N/2 ) = ZERO XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO ! end if DO 70 IY = 1, NINC INCY = INC( IY ) ! LY = ABS( INCY )*N 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, N, Y, 1, YY, & ABS( INCY ), 0, N - 1, RESET, & ! TRANSL ) ! ! Save every datum before calling the ! subroutine. ! NC = NC + 1 UPLOS = UPLO NS = N KS = K ALS = ALPHA AS(1:laa) = AA(1:laa) LDAS = LDA DO 20 I = 1, LX XS( I ) = XX( I ) 20 continue INCXS = INCX BLS = BETA DO 30 I = 1, LY YS( I ) = YY( I ) 30 continue ! ! Call the subroutine. ! INCYS = INCY if ( FULL ) then call CHEMV( UPLO, N, ALPHA, AA, LDA, XX, & INCX, BETA, YY, INCY ) else if ( BANDED ) then call CHBMV( UPLO, N, K, ALPHA, AA, LDA, & XX, INCX, BETA, YY, INCY ) else if ( PACKED ) then call CHPMV( UPLO, N, ALPHA, AA, 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 = 9992 ) end if FATAL = .TRUE. ! ! See what data changed inside subroutines. ! end if ISAME( 1 ) = UPLO == UPLOS ISAME( 2 ) = NS == N if ( FULL ) then ISAME( 3 ) = ALS == ALPHA ISAME( 4 ) = LCE( AS, AA, LAA ) ISAME( 5 ) = LDAS == LDA ISAME( 6 ) = LCE( XS, XX, LX ) ISAME( 7 ) = INCXS == INCX ISAME( 8 ) = BLS == BETA if ( NULL ) then ISAME( 9 ) = LCE( YS, YY, LY ) else ISAME( 9 ) = LCERES( 'GE', ' ', 1, N, & YS, YY, ABS( INCY ) ) end if ISAME( 10 ) = INCYS == INCY else if ( BANDED ) then ISAME( 3 ) = KS == K 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, N, & YS, YY, ABS( INCY ) ) end if ISAME( 11 ) = INCYS == INCY else if ( PACKED ) then ISAME( 3 ) = ALS == ALPHA ISAME( 4 ) = LCE( AS, AA, LAA ) ISAME( 5 ) = LCE( XS, XX, LX ) ISAME( 6 ) = INCXS == INCX ISAME( 7 ) = BLS == BETA if ( NULL ) then ISAME( 8 ) = LCE( YS, YY, LY ) else ISAME( 8 ) = LCERES( 'GE', ' ', 1, N, & YS, YY, ABS( INCY ) ) end if ISAME( 9 ) = 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( 'N', N, 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, & UPLO, N, ALPHA, LDA, & INCX, BETA, INCY else if ( BANDED ) then write ( NOUT, FMT = 9995 )NC, SNAME, & UPLO, N, & ALPHA, LDA, INCX, BETA, INCY else if ( PACKED ) then write ( NOUT, FMT = 9995 )NC, SNAME, & UPLO, N, ALPHA, INCX, & BETA, INCY end if end if ! end if ! 50 continue ! 60 continue ! 70 continue ! 80 continue ! 90 continue ! 100 continue ! ! Report result. ! 110 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, ''',', I3, ',(', F4.1, ',', & F4.1, '), AP, 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, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of CCHK22. ! '******' ) end subroutine CCHK23 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NBET, BET, NMAX, A, AA, AS, B, BB, BS, C, CC, & !*****************************************************************************80 ! !! CCHK23 is a quick check for CHEMM and CSYMM. ! !***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 CHEMM and CSYMM. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CHEMM, CMAKE3, CMMCH, CSYMM, LCE, LCERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CCHK23 ! .. 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, ICS, ICU, IM, IN, LAA, LBB, LCC, & LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, & NARGS, NC, NERR, NS LOGICAL CONJ, FTL, LEFT, NULL, RESET CHARACTER*1 SIDE, SIDES, UPLO, UPLOS ! .. Local Arrays .. CHARACTER*2 ICHU, ICHS ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LCE, LCERES ! .. External Subroutines .. EXTERNAL LCE, LCERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL CHEMM, CSYMM, CMAKE3, CMMCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN !***FIRST EXECUTABLE STATEMENT CCHK23 DATA ICHS/'LR'/, ICHU/'UL'/ ! CONJ = SNAME( 2: 3 ) == 'HE' NARGS = 12 NC = 0 RESET = .TRUE. ! ERRMAX = RZERO DO 100 IM = 1, NIDIM ! M = IDIM( IM ) DO 90 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 90 LCC = LDC*N ! Set LDB to 1 more than minimum value if room. NULL = N <= 0.OR.M <= 0 LDB = M if ( LDB < NMAX ) & ! Skip tests if not enough room. LDB = LDB + 1 if ( LDB > NMAX ) & GO TO 90 ! ! Generate the matrix B. ! LBB = LDB*N call CMAKE3( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, & ! ZERO ) DO 80 ICS = 1, 2 SIDE = ICHS( ICS: ICS ) ! LEFT = SIDE == 'L' if ( LEFT ) then NA = M else NA = N ! Set LDA to 1 more than minimum value if room. end if LDA = NA if ( LDA < NMAX ) & ! Skip tests if not enough room. LDA = LDA + 1 if ( LDA > NMAX ) & GO TO 80 ! LAA = LDA*NA DO 70 ICU = 1, 2 ! ! Generate the hermitian or symmetric matrix A. ! UPLO = ICHU( ICU: ICU ) call CMAKE3(SNAME( 2: 3 ), UPLO, ' ', NA, NA, A, NMAX, & ! AA, LDA, 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 SIDES = SIDE UPLOS = UPLO MS = M NS = N 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 if ( CONJ ) then call CHEMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, & BB, LDB, BETA, CC, LDC ) else call CSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, & BB, LDB, BETA, CC, LDC ) ! ! Check if error-exit was taken incorrectly. ! end if 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 ) = SIDES == SIDE ISAME( 2 ) = UPLOS == UPLO ISAME( 3 ) = MS == M ISAME( 4 ) = NS == N ISAME( 5 ) = ALS == ALPHA ISAME( 6 ) = LCE( AS, AA, LAA ) ISAME( 7 ) = LDAS == LDA ISAME( 8 ) = LCE( BS, BB, LBB ) ISAME( 9 ) = LDBS == LDB ISAME( 10 ) = BLS == BETA if ( NULL ) then ISAME( 11 ) = LCE( CS, CC, LCC ) else ISAME( 11 ) = LCERES( 'GE', ' ', M, N, CS, & CC, LDC ) end if ! ! If data was incorrectly changed, report and ! return. ! ISAME( 12 ) = 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 if ( LEFT ) then call CMMCH( 'N', 'N', M, N, M, ALPHA, A, & NMAX, B, NMAX, BETA, C, NMAX, & CT, G, CC, LDC, EPS, ERR, & FTL, NOUT, .TRUE., & kprint ) else call CMMCH( 'N', 'N', M, N, N, ALPHA, B, & NMAX, A, NMAX, BETA, C, NMAX, & CT, G, CC, LDC, EPS, ERR, & FTL, NOUT, .TRUE., kprint ) end if 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, SIDE, & UPLO, M, N, ALPHA, LDA, LDB, BETA, & LDC end if end if 50 continue 60 continue 70 continue 80 continue 90 continue ! ! Report result. ! 100 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, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), & '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, & ',', F4.1, '), C,', I3, ') .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of CCHK23. ! '******' ) end subroutine CCHK32 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NKB, KB, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, & !*****************************************************************************80 ! !! CCHK32 is a quick check for CTRMV, CTBMV, CTPMV, CTRSV, CTBSV and CTPSV. ! !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for CTRMV, CTBMV, CTPMV, CTRSV, CTBSV and CTPSV. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CMAKE2, CMVCH, CTBMV, CTBSV, CTPMV, CTPSV, CTRMV, ! CTRSV, LCE, LCERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CCHK32 ! .. Parameters .. XT, G, Z) COMPLEX ZERO, HALF, ONE PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), & ONE = ( 1.0, 0.0 ) ) REAL RZERO ! .. Scalar Arguments .. PARAMETER ( RZERO = 0.0 ) LOGICAL FATAL REAL EPS, THRESH integer INCMAX, KPRINT, NIDIM, NINC, NKB, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), & AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), & XT( NMAX ), XX( NMAX*INCMAX ), Z( NMAX ) REAL G( NMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ), INC( NINC ), KB( NKB ) COMPLEX TRANSL REAL ERR, ERRMAX integer I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, & KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NERR, NK, & NS LOGICAL BANDED, FTL, FULL, NULL, PACKED, RESET CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS CHARACTER*2 ICHD, ICHU ! .. Local Arrays .. CHARACTER*3 ICHT ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LCE, LCERES ! .. External Subroutines .. EXTERNAL LCE, LCERES, NUMXER EXTERNAL CMAKE2, CMVCH, CTBMV, CTBSV, CTPMV, CTPSV, & ! .. Intrinsic Functions .. CTRMV, CTRSV ! .. Data statements .. INTRINSIC ABS, MAX !***FIRST EXECUTABLE STATEMENT CCHK32 DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ FULL = SNAME( 3: 3 ) == 'R' BANDED = SNAME( 3: 3 ) == 'B' ! Define the number of arguments. PACKED = SNAME( 3: 3 ) == 'P' if ( FULL ) then NARGS = 8 else if ( BANDED ) then NARGS = 9 else if ( PACKED ) then NARGS = 7 end if NC = 0 RESET = .TRUE. ! Set up zero vector for CMVCH. ERRMAX = RZERO DO I = 1, NMAX Z( I ) = ZERO end do DO 110 IN = 1, NIDIM N = IDIM( IN ) if ( BANDED ) then NK = NKB else NK = 1 end if DO 100 IK = 1, NK if ( BANDED ) then K = KB( IK ) else K = N - 1 ! Set LDA to 1 more than minimum value if room. end if if ( BANDED ) then LDA = K + 1 else LDA = N end if if ( LDA < NMAX ) & ! Skip tests if not enough room. LDA = LDA + 1 if ( LDA > NMAX ) & GO TO 100 if ( PACKED ) then LAA = ( N*( N + 1 ) )/2 else LAA = LDA*N end if NULL = N <= 0 DO 90 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) DO 80 ICT = 1, 3 TRANS = ICHT( ICT: ICT ) DO 70 ICD = 1, 2 ! ! Generate the matrix A. ! DIAG = ICHD( ICD: ICD ) TRANSL = ZERO call CMAKE2( SNAME( 2: 3 ), UPLO, DIAG, N, N, A, & NMAX, AA, LDA, K, K, RESET, TRANSL ) DO 60 IX = 1, NINC INCX = INC( IX ) ! ! Generate the vector X. ! LX = ABS( INCX )*N TRANSL = HALF call CMAKE2( 'GE', ' ', ' ', 1, N, X, 1, XX, & ABS( INCX ), 0, N - 1, RESET, & TRANSL ) if ( N > 1 ) then X( N/2 ) = ZERO XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO end if ! ! Save every datum before calling the subroutine. ! NC = NC + 1 UPLOS = UPLO TRANSS = TRANS DIAGS = DIAG NS = N KS = K DO 20 I = 1, LAA AS( I ) = AA( I ) 20 continue LDAS = LDA DO 30 I = 1, LX XS( I ) = XX( I ) 30 continue ! ! Call the subroutine. ! INCXS = INCX if ( SNAME( 4: 5 ) == 'MV' ) then if ( FULL ) then call CTRMV( UPLO, TRANS, DIAG, N, AA, LDA, & XX, INCX ) else if ( BANDED ) then call CTBMV( UPLO, TRANS, DIAG, N, K, AA, & LDA, XX, INCX ) else if ( PACKED ) then call CTPMV( UPLO, TRANS, DIAG, N, AA, XX, & INCX ) end if else if ( SNAME( 4: 5 ) == 'SV' ) then if ( FULL ) then call CTRSV( UPLO, TRANS, DIAG, N, AA, LDA, & XX, INCX ) else if ( BANDED ) then call CTBSV( UPLO, TRANS, DIAG, N, K, AA, & LDA, XX, INCX ) else if ( PACKED ) then call CTPSV( UPLO, TRANS, DIAG, N, AA, XX, & INCX ) end if ! ! Check if error-exit was taken incorrectly. ! end if if ( NUMXER(NERR) /= 0 ) then if ( kprint >= 2 ) then write ( NOUT, FMT = 9992 ) end if FATAL = .TRUE. ! ! See what data changed inside subroutines. ! end if ISAME( 1 ) = UPLO == UPLOS ISAME( 2 ) = TRANS == TRANSS ISAME( 3 ) = DIAG == DIAGS ISAME( 4 ) = NS == N if ( FULL ) then ISAME( 5 ) = LCE( AS, AA, LAA ) ISAME( 6 ) = LDAS == LDA if ( NULL ) then ISAME( 7 ) = LCE( XS, XX, LX ) else ISAME( 7 ) = LCERES( 'GE', ' ', 1, N, XS, & XX, ABS( INCX ) ) end if ISAME( 8 ) = INCXS == INCX else if ( BANDED ) then ISAME( 5 ) = KS == K ISAME( 6 ) = LCE( AS, AA, LAA ) ISAME( 7 ) = LDAS == LDA if ( NULL ) then ISAME( 8 ) = LCE( XS, XX, LX ) else ISAME( 8 ) = LCERES( 'GE', ' ', 1, N, XS, & XX, ABS( INCX ) ) end if ISAME( 9 ) = INCXS == INCX else if ( PACKED ) then ISAME( 5 ) = LCE( AS, AA, LAA ) if ( NULL ) then ISAME( 6 ) = LCE( XS, XX, LX ) else ISAME( 6 ) = LCERES( 'GE', ' ', 1, N, XS, & XX, ABS( INCX ) ) end if ISAME( 7 ) = INCXS == INCX ! ! 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. if ( .NOT.NULL ) then ! ! Check the result. ! if ( SNAME( 4: 5 ) == 'MV' ) then call CMVCH( TRANS, N, N, ONE, A, NMAX, X, & INCX, ZERO, Z, INCX, XT, G, & XX, EPS, ERR, FTL, NOUT, & .TRUE., KPRINT) ! ! Compute approximation to original vector. ! else if ( SNAME( 4: 5 ) == 'SV' ) then DO 50 I = 1, N Z( I ) = XX( 1 + ( I - 1 )* & ABS( INCX ) ) XX( 1 + ( I - 1 )*ABS( INCX ) ) & = X( I ) 50 continue call CMVCH( TRANS, N, N, ONE, A, NMAX, Z, & INCX, ZERO, X, INCX, XT, G, & XX, EPS, ERR, FTL, NOUT, & .FALSE., kprint ) end if 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, & UPLO, TRANS, DIAG, N, LDA, & INCX else if ( BANDED ) then write ( NOUT, FMT = 9995 )NC, SNAME, & UPLO, TRANS, DIAG, N, K, & LDA, INCX else if ( PACKED ) then write ( NOUT, FMT = 9995 )NC, SNAME, & UPLO, TRANS, DIAG, N, INCX end if end if end if 60 continue 70 continue 80 continue 90 continue 100 continue ! ! Report result. ! 110 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, '(', 3( '''', A1, ''',' ), I3, ', AP, ', & 'X,', I2, ') .' ) 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), & ' A,', I3, ', X,', I2, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of CCHK32. ! '******' ) end subroutine CCHK33 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NMAX, A, AA, AS, B, BB, BS, CT, G, C) !*****************************************************************************80 ! !! CCHK33 is a quick check for CTRMM and CTRSM. ! !***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 CTRMM and CTRSM. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CMAKE3, CMMCH, CTRMM, CTRSM, LCE, LCERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CCHK33 ! .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) REAL RZERO ! .. Scalar Arguments .. PARAMETER ( RZERO = 0.0 ) LOGICAL FATAL REAL EPS, THRESH integer KPRINT, NALF, 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 ), BS( NMAX*NMAX ), & C( NMAX, NMAX ), & CT( NMAX ) REAL G( NMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ) COMPLEX ALPHA, ALS REAL ERR, ERRMAX integer I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, & LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, & NERR, NS LOGICAL FTL, LEFT, NULL, RESET CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, & UPLOS CHARACTER*2 ICHU, ICHS, ICHD ! .. Local Arrays .. CHARACTER*3 ICHT ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LCE, LCERES ! .. External Subroutines .. EXTERNAL LCE, LCERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL CTRMM, CTRSM, CMAKE3, CMMCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN !***FIRST EXECUTABLE STATEMENT CCHK33 DATA ICHS/'LR'/, ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ NARGS = 11 NC = 0 RESET = .TRUE. ! Set up zero matrix for CMMCH. ERRMAX = RZERO C(1:nmax,1:nmax) = ZERO DO 140 IM = 1, NIDIM M = IDIM( IM ) DO 130 IN = 1, NIDIM ! Set LDB to 1 more than minimum value if room. N = IDIM( IN ) LDB = M if ( LDB < NMAX ) & ! Skip tests if not enough room. LDB = LDB + 1 if ( LDB > NMAX ) & GO TO 130 LBB = LDB*N NULL = M <= 0.OR.N <= 0 DO 120 ICS = 1, 2 SIDE = ICHS( ICS: ICS ) LEFT = SIDE == 'L' if ( LEFT ) then NA = M else NA = N ! Set LDA to 1 more than minimum value if room. end if LDA = NA if ( LDA < NMAX ) & ! Skip tests if not enough room. LDA = LDA + 1 if ( LDA > NMAX ) & GO TO 130 ! LAA = LDA*NA DO 110 ICU = 1, 2 ! UPLO = ICHU( ICU: ICU ) DO 100 ICT = 1, 3 ! TRANSA = ICHT( ICT: ICT ) DO 90 ICD = 1, 2 ! DIAG = ICHD( ICD: ICD ) DO 80 IA = 1, NALF ! ! Generate the matrix A. ! ALPHA = ALF( IA ) call CMAKE3( 'TR', UPLO, DIAG, NA, NA, A, & ! ! Generate the matrix B. ! NMAX, AA, LDA, RESET, ZERO ) call CMAKE3( 'GE', ' ', ' ', M, N, B, NMAX, & ! BB, LDB, RESET, ZERO ) ! ! Save every datum before calling the ! subroutine. ! NC = NC + 1 SIDES = SIDE UPLOS = UPLO TRANAS = TRANSA DIAGS = DIAG MS = M NS = N ALS = ALPHA DO 30 I = 1, LAA AS( I ) = AA( I ) 30 continue LDAS = LDA DO 40 I = 1, LBB BS( I ) = BB( I ) 40 continue ! ! Call the subroutine. ! LDBS = LDB if ( SNAME( 4: 5 ) == 'MM' ) then call CTRMM( SIDE, UPLO, TRANSA, DIAG, M, & N, ALPHA, AA, LDA, BB, LDB ) else if ( SNAME( 4: 5 ) == 'SM' ) then call CTRSM( SIDE, UPLO, TRANSA, DIAG, M, & N, ALPHA, AA, LDA, BB, LDB ) ! ! Check if error-exit was taken incorrectly. ! end if 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 ) = SIDES == SIDE ISAME( 2 ) = UPLOS == UPLO ISAME( 3 ) = TRANAS == TRANSA ISAME( 4 ) = DIAGS == DIAG ISAME( 5 ) = MS == M ISAME( 6 ) = NS == N ISAME( 7 ) = ALS == ALPHA ISAME( 8 ) = LCE( AS, AA, LAA ) ISAME( 9 ) = LDAS == LDA if ( NULL ) then ISAME( 10 ) = LCE( BS, BB, LBB ) else ISAME( 10 ) = LCERES( 'GE', ' ', M, N, BS, & BB, LDB ) end if ! ! If data was incorrectly changed, report and ! return. ! ISAME( 11 ) = LDBS == LDB DO 50 I = 1, NARGS if ( .NOT. ISAME( I ) ) then FATAL = .TRUE. if ( kprint >= 2 ) then write ( NOUT, FMT = 9998 )I end if end if ! 50 continue FTL = .FALSE. if ( .NOT.NULL ) then ! ! Check the result. ! if ( SNAME( 4: 5 ) == 'MM' ) then if ( LEFT ) then call CMMCH( TRANSA, 'N', M, N, M, & ALPHA, A, NMAX, B, NMAX, & ZERO, C, NMAX, CT, G, & BB, LDB, EPS, ERR, & FTL, NOUT, .TRUE., & kprint ) else call CMMCH( 'N', TRANSA, M, N, N, & ALPHA, B, NMAX, A, NMAX, & ZERO, C, NMAX, CT, G, & BB, LDB, EPS, ERR, & FTL, NOUT, .TRUE., & kprint ) end if ! ! Compute approximation to original ! matrix. ! else if ( SNAME( 4: 5 ) == 'SM' ) then DO 70 J = 1, N DO 60 I = 1, M C( I, J ) = BB( I + ( J - 1 )* & LDB ) BB( I + ( J - 1 )*LDB ) = ALPHA* & B( I, J ) 60 continue ! 70 continue if ( LEFT ) then call CMMCH( TRANSA, 'N', M, N, M, & ONE, A, NMAX, C, NMAX, & ZERO, B, NMAX, CT, G, & BB, LDB, EPS, ERR, & FTL, NOUT, .FALSE., & kprint ) else call CMMCH( 'N', TRANSA, M, N, N, & ONE, C, NMAX, A, NMAX, & ZERO, B, NMAX, CT, G, & BB, LDB, EPS, ERR, & FTL, NOUT, .FALSE., & kprint ) end if end if 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, SIDE, UPLO, TRANSA, & DIAG, M, N, ALPHA, LDA, LDB end if ! end if ! 80 continue ! 90 continue ! 100 continue ! 110 continue ! 120 continue ! 130 continue ! ! Report result. ! 140 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, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), & '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ', & ' .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of CCHK33. ! '******' ) end subroutine CCHK42 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, & Y, YY, YS, YT, G, Z) !! CCHK42 !***SUBSIDIARY !***PURPOSE Quick check for CGERC and CGERU. !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for CGERC and CGERU. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CGERC, CGERU, CMAKE2, CMVCH, LCE, LCERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CCHK42 ! .. Parameters .. COMPLEX ZERO, HALF, ONE PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), & ONE = ( 1.0, 0.0 ) ) REAL RZERO ! .. Scalar Arguments .. PARAMETER ( RZERO = 0.0 ) LOGICAL FATAL REAL EPS, THRESH integer INCMAX, KPRINT, NALF, NIDIM, NINC, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), & XX( NMAX*INCMAX ), Y( NMAX ), & YS( NMAX*INCMAX ), YT( NMAX ), & YY( NMAX*INCMAX ), Z( NMAX ) REAL G( NMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ), INC( NINC ) COMPLEX ALPHA, ALS, TRANSL REAL ERR, ERRMAX integer I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, & IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, & NC, ND, NERR, NS ! .. Local Arrays .. LOGICAL CONJ, FTL, NULL, RESET COMPLEX W( 1 ) ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LCE, LCERES ! .. External Subroutines .. EXTERNAL LCE, LCERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL CGERC, CGERU, CMAKE2, CMVCH !***FIRST EXECUTABLE STATEMENT CCHK42 INTRINSIC ABS, CONJG, MAX, MIN ! Define the number of arguments. CONJ = SNAME( 5: 5 ) == 'C' NARGS = 9 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 ) & ! ! Set LDA to 1 more than minimum value if room. ! M = min ( N + ND, NMAX ) LDA = M if ( LDA < NMAX ) & LDA = LDA + 1 ! ! Skip tests if not enough room. ! if ( LDA > NMAX ) & GO TO 110 LAA = LDA*N NULL = N <= 0.OR.M <= 0 DO 100 IX = 1, NINC INCX = INC( IX ) ! ! Generate the vector X. ! LX = ABS( INCX )*M TRANSL = HALF call CMAKE2( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), & 0, M - 1, RESET, TRANSL ) if ( M > 1 ) then X( M/2 ) = ZERO XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO ! end if DO 90 IY = 1, NINC INCY = INC( IY ) ! ! Generate the vector Y. ! LY = ABS( INCY )*N TRANSL = ZERO call CMAKE2( 'GE', ' ', ' ', 1, N, Y, 1, YY, & ABS( INCY ), 0, N - 1, RESET, TRANSL ) if ( N > 1 ) then Y( N/2 ) = ZERO YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO end if DO 80 IA = 1, NALF ! ! Generate the matrix A. ! ALPHA = ALF( IA ) TRANSL = ZERO call CMAKE2(SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, & AA, LDA, M - 1, N - 1, RESET, TRANSL ) ! ! Save every datum before calling the subroutine. ! NC = NC + 1 MS = M NS = N ALS = ALPHA AS(1:laa) = AA(1:laa) LDAS = LDA XS(1:lx) = XX(1:lx) INCXS = INCX YS(1:ly) = YY(1:ly) ! ! Call the subroutine. ! INCYS = INCY if ( CONJ ) then call CGERC( M, N, ALPHA, XX, INCX, YY, INCY, AA, LDA ) else call CGERU( M, N, ALPHA, XX, INCX, YY, INCY, AA, LDA ) ! ! 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 subroutine. ! end if ISAME( 1 ) = MS == M ISAME( 2 ) = NS == N ISAME( 3 ) = ALS == ALPHA ISAME( 4 ) = LCE( XS, XX, LX ) ISAME( 5 ) = INCXS == INCX ISAME( 6 ) = LCE( YS, YY, LY ) ISAME( 7 ) = INCYS == INCY if ( NULL ) then ISAME( 8 ) = LCE( AS, AA, LAA ) else ISAME( 8 ) = LCERES( 'GE', ' ', M, N, AS, AA, & LDA ) end if ! ! If data was incorrectly changed, report and return. ! ISAME( 9 ) = LDAS == LDA 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 column by column. ! if ( .NOT.NULL ) then if ( INCX > 0 ) then Z(1:m) = X(1:m) else DO 60 I = 1, M Z( I ) = X( M - I + 1 ) 60 continue end if DO 70 J = 1, N if ( INCY > 0 ) then W( 1 ) = Y( J ) else W( 1 ) = Y( N - J + 1 ) end if if ( CONJ ) & W( 1 ) = CONJG( W( 1 ) ) call CMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, & ONE, A( 1, J ), 1, YT, G, & AA( 1 + ( J - 1 )*LDA ), EPS, & ERR, FTL, NOUT, .TRUE., KPRINT) ERRMAX = max ( ERRMAX, ERR ) 70 continue end if if ( FTL ) then FATAL = .TRUE. if ( kprint >= 3 ) then write ( NOUT, FMT = 9995 )J write ( NOUT, FMT = 9996 )SNAME write ( NOUT, FMT = 9994 )NC, SNAME, M, & N, ALPHA, INCX, INCY, LDA end if ! end if ! 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( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), '(', F4.1, ',', F4.1, & '), X,', I2, ', Y,', I2, ', A,', I3, ') ', & ' .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & '******' ) end subroutine CCHK43 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NBET, BET, NMAX, A, AA, AS, B, BB, BS, C, CC, & CS, CT, G) !! CCHK43 !***SUBSIDIARY !***PURPOSE Quick check for CHERK and CSYRK. !***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 CHERK and CSYRK. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CHERK, CMAKE3, CMMCH, CSYRK, LCE, LCERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CCHK43 ! .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0, 0.0 )) REAL RZERO, RONE ! .. Scalar Arguments .. PARAMETER ( RZERO = 0.0, RONE = 1.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 ), BS( NMAX*NMAX ), BET(NBET), & C( NMAX, NMAX ), CC( NMAX*NMAX ), & CT( NMAX ), CS( NMAX*NMAX ) REAL G( NMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ) COMPLEX ALPHA, ALS, BETA, BETS REAL ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS integer I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, & LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, & NARGS, NC, NERR, NS LOGICAL CONJ, FTL, NULL, RESET, TRAN, UPPER CHARACTER*1 TRANS, TRANSS, UPLO, TRANST, UPLOS ! .. Local Arrays .. CHARACTER*2 ICHU, ICHT ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LCE, LCERES ! .. External Subroutines .. EXTERNAL LCE, LCERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL CHERK, CSYRK, CMAKE3, CMMCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN !***FIRST EXECUTABLE STATEMENT CCHK43 DATA ICHU/'UL'/, ICHT/'NC'/ ! CONJ = SNAME( 2: 3 ) == 'HE' NARGS = 10 NC = 0 RESET = .TRUE. ! ERRMAX = RZERO DO 100 IN = 1, NIDIM ! Set LDC to 1 more than minimum value if room. N = IDIM( IN ) LDC = N if ( LDC < NMAX ) & ! Skip tests if not enough room. LDC = LDC + 1 if ( LDC > NMAX ) & GO TO 100 ! LCC = LDC*N DO 90 IK = 1, NIDIM ! K = IDIM( IK ) DO 80 ICT = 1, 2 TRANS = ICHT( ICT: ICT ) TRAN = TRANS == 'C' if ( TRAN .and. .NOT.CONJ ) & TRANS = 'T' if ( TRAN ) then MA = K NA = N else MA = N 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 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) UPPER = UPLO == 'U' DO 60 IA = 1, NALF ALPHA = ALF( IA ) if ( CONJ ) then RALPHA = REAL( ALPHA ) ALPHA = CMPLX( RALPHA, RZERO ) end if DO 50 IB = 1, NBET BETA = BET( IB ) if ( CONJ ) then RBETA = REAL( BETA ) BETA = CMPLX( RBETA, RZERO ) end if NULL = N <= 0 if ( CONJ ) & NULL = NULL.OR.( ( K <= 0.OR.RALPHA == & ! ! Generate the matrix C. ! RZERO ) .and. RBETA == RONE ) call CMAKE3( SNAME( 2: 3 ), UPLO, ' ', N, N, C, & NMAX, CC, LDC, RESET, ZERO ) ! ! Save every datum before calling the subroutine. ! NC = NC + 1 UPLOS = UPLO TRANSS = TRANS NS = N KS = K if ( CONJ ) then RALS = RALPHA else ALS = ALPHA end if AS(1:laa) = AA(1:laa) LDAS = LDA if ( CONJ ) then RBETS = RBETA else BETS = BETA end if DO 20 I = 1, LCC CS( I ) = CC( I ) 20 continue ! ! Call the subroutine. ! LDCS = LDC if ( CONJ ) then call CHERK( UPLO, TRANS, N, K, RALPHA, AA, & LDA, RBETA, CC, LDC ) else call CSYRK( UPLO, TRANS, N, K, ALPHA, AA, & LDA, BETA, CC, LDC ) ! ! Check if error-exit was taken incorrectly. ! end if if ( NUMXER(NERR) /= 0 ) then if ( kprint >= 2 ) then write ( NOUT, FMT = 9992 ) end if FATAL = .TRUE. ! ! See what data changed inside subroutines. ! end if ISAME( 1 ) = UPLOS == UPLO ISAME( 2 ) = TRANSS == TRANS ISAME( 3 ) = NS == N ISAME( 4 ) = KS == K if ( CONJ ) then ISAME( 5 ) = RALS == RALPHA else ISAME( 5 ) = ALS == ALPHA end if ISAME( 6 ) = LCE( AS, AA, LAA ) ISAME( 7 ) = LDAS == LDA if ( CONJ ) then ISAME( 8 ) = RBETS == RBETA else ISAME( 8 ) = BETS == BETA end if if ( NULL ) then ISAME( 9 ) = LCE( CS, CC, LCC ) else ISAME( 9 ) = LCERES( SNAME( 2: 3 ), UPLO, N, & N, CS, CC, LDC ) end if ! ! If data was incorrectly changed, report and ! return. ! ISAME( 10 ) = LDCS == LDC DO 30 I = 1, NARGS if ( .NOT. ISAME( I ) ) then FATAL = .TRUE. if ( kprint >= 2 ) then write ( NOUT, FMT = 9998 )I end if end if ! 30 continue ! ! Check the result column by column. ! if ( .NOT.NULL ) then if ( CONJ ) then TRANST = 'C' else TRANST = 'T' end if JC = 1 DO 40 J = 1, N if ( UPPER ) then JJ = 1 LJ = J else JJ = J LJ = N - J + 1 end if if ( TRAN ) then FTL = .FALSE. call CMMCH( TRANST, 'N', LJ, 1, K, & ALPHA, A( 1, JJ ), NMAX, & A( 1, J ), NMAX, BETA, & C( JJ, J ), NMAX, CT, G, & CC( JC ), LDC, EPS, ERR, & FTL, NOUT, .TRUE., & kprint ) else FTL = .FALSE. call CMMCH( 'N', TRANST, LJ, 1, K, & ALPHA, A( JJ, 1 ), NMAX, & A( J, 1 ), NMAX, BETA, & C( JJ, J ), NMAX, CT, G, & CC( JC ), LDC, EPS, ERR, & FTL, NOUT, .TRUE., & kprint ) end if if ( UPPER ) then JC = JC + LDC else JC = JC + LDC + 1 end if ERRMAX = max ( ERRMAX, ERR ) if ( FTL ) then FATAL = .TRUE. if ( kprint >= 3 ) then write ( NOUT, FMT = 9996 )SNAME if ( CONJ ) then write ( NOUT, FMT = 9994 )NC, SNAME, & UPLO, TRANS, N, K, RALPHA, & LDA, RBETA, LDC else write ( NOUT, FMT = 9993 )NC, SNAME, & UPLO, TRANS, N, K, ALPHA, & LDA, BETA, LDC end if end if end if 40 continue ! end if ! 50 continue ! 60 continue ! 70 continue ! 80 continue ! 90 continue ! ! Report result. ! 100 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:' ) 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), & F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ', & ' .' ) 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), & '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1, & '), C,', I3, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of CCHK43. ! '******' ) end subroutine CCHK52 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, & Y, YY, YS, YT, G, Z) !! CCHK52 !***SUBSIDIARY !***PURPOSE Quick check for CHER and CHPR. !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for CHER and CHPR. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CHER, CHPR, CMAKE2, CMVCH, LCE, LCERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CCHK52 ! .. Parameters .. COMPLEX ZERO, HALF, ONE PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), & ONE = ( 1.0, 0.0 ) ) REAL RZERO ! .. Scalar Arguments .. PARAMETER ( RZERO = 0.0 ) LOGICAL FATAL REAL EPS, THRESH integer INCMAX, KPRINT, NALF, NIDIM, NINC, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), & XX( NMAX*INCMAX ), Y( NMAX ), & YS( NMAX*INCMAX ), YT( NMAX ), & YY( NMAX*INCMAX ), Z( NMAX ) REAL G( NMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ), INC( NINC ) COMPLEX ALPHA, TRANSL REAL ERR, ERRMAX, RALPHA, RALS integer I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, & LDA, LDAS, LJ, LX, N, NARGS, NC, NERR, NS LOGICAL FTL, FULL, NULL, PACKED, RESET, UPPER CHARACTER*1 UPLO, UPLOS ! .. Local Arrays .. CHARACTER*2 ICH COMPLEX W( 1 ) ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LCE, LCERES ! .. External Subroutines .. EXTERNAL LCE, LCERES ! .. Intrinsic Functions .. EXTERNAL CHER, CHPR, CMAKE2, CMVCH ! .. Data statements .. INTRINSIC ABS, CMPLX, CONJG, MAX, REAL !***FIRST EXECUTABLE STATEMENT CCHK52 DATA ICH/'UL'/ FULL = SNAME( 3: 3 ) == 'E' ! Define the number of arguments. PACKED = SNAME( 3: 3 ) == 'P' if ( FULL ) then NARGS = 7 else if ( PACKED ) then NARGS = 6 ! end if NC = 0 RESET = .TRUE. ! ERRMAX = RZERO DO 100 IN = 1, NIDIM ! Set LDA to 1 more than minimum value if room. N = IDIM( IN ) LDA = N if ( LDA < NMAX ) & ! Skip tests if not enough room. LDA = LDA + 1 if ( LDA > NMAX ) & GO TO 100 if ( PACKED ) then LAA = ( N*( N + 1 ) )/2 else LAA = LDA*N ! end if DO 90 IC = 1, 2 UPLO = ICH( IC: IC ) ! UPPER = UPLO == 'U' DO 80 IX = 1, NINC INCX = INC( IX ) ! ! Generate the vector X. ! LX = ABS( INCX )*N TRANSL = HALF call CMAKE2( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), & 0, N - 1, RESET, TRANSL ) if ( N > 1 ) then X( N/2 ) = ZERO XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO ! end if DO 70 IA = 1, NALF RALPHA = REAL( ALF( IA ) ) ALPHA = CMPLX( RALPHA, RZERO ) ! ! Generate the matrix A. ! NULL = N <= 0.OR.RALPHA == RZERO TRANSL = ZERO call CMAKE2( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, & ! AA, LDA, N - 1, N - 1, RESET, TRANSL ) ! ! Save every datum before calling the subroutine. ! NC = NC + 1 UPLOS = UPLO NS = N RALS = RALPHA AS(1:laa) = AA(1:laa) LDAS = LDA DO 20 I = 1, LX XS( I ) = XX( I ) 20 continue ! ! Call the subroutine. ! INCXS = INCX if ( FULL ) then call CHER( UPLO, N, RALPHA, XX, INCX, AA, LDA ) else if ( PACKED ) then call CHPR( UPLO, N, RALPHA, XX, INCX, AA ) ! ! Check if error-exit was taken incorrectly. ! end if if ( NUMXER(NERR) /= 0 ) then if ( kprint >= 2 ) then write ( NOUT, FMT = 9992 ) end if FATAL = .TRUE. ! ! See what data changed inside subroutines. ! end if ISAME( 1 ) = UPLO == UPLOS ISAME( 2 ) = NS == N ISAME( 3 ) = RALS == RALPHA ISAME( 4 ) = LCE( XS, XX, LX ) ISAME( 5 ) = INCXS == INCX if ( NULL ) then ISAME( 6 ) = LCE( AS, AA, LAA ) else ISAME( 6 ) = LCERES( SNAME( 2: 3 ), UPLO, N, N, AS, & AA, LDA ) end if if ( .NOT.PACKED ) then ISAME( 7 ) = LDAS == LDA ! ! If data was incorrectly changed, report and return. ! end if DO 30 I = 1, NARGS if ( .NOT. ISAME( I ) ) then FATAL = .TRUE. if ( kprint >= 2 ) then write ( NOUT, FMT = 9998 )I end if end if ! 30 continue FTL = .FALSE. ! ! Check the result column by column. ! if ( .NOT.NULL ) then if ( INCX > 0 ) then DO 40 I = 1, N Z( I ) = X( I ) 40 continue else DO 50 I = 1, N Z( I ) = X( N - I + 1 ) 50 continue end if JA = 1 DO 60 J = 1, N W( 1 ) = CONJG( Z( J ) ) if ( UPPER ) then JJ = 1 LJ = J else JJ = J LJ = N - J + 1 end if call CMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, & 1, ONE, A( JJ, J ), 1, YT, G, & AA( JA ), EPS, ERR, FTL, NOUT, & .TRUE., kprint ) if ( FULL ) then if ( UPPER ) then JA = JA + LDA else JA = JA + LDA + 1 end if else JA = JA + LJ end if ERRMAX = max ( ERRMAX, ERR ) 60 continue end if if ( FTL ) then FATAL = .TRUE. if ( kprint >= 3 ) then write (NOUT, FMT = 9996) SNAME if ( FULL ) then write ( NOUT, FMT = 9993 )NC, SNAME, & UPLO, N, RALPHA, INCX, LDA else if ( PACKED ) then write ( NOUT, FMT = 9994 )NC, SNAME, & UPLO, N, RALPHA, INCX end if end if ! end if ! 70 continue ! 80 continue ! 90 continue ! ! Report result. ! 100 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:' ) 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', & I2, ', AP) .' ) 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', & I2, ', A,', I3, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of CCHK52. ! '******' ) end subroutine CCHK53 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NBET, BET, NMAX, AB, AA, AS, BB, BS, C, CC, & CS, CT, G, W) !! CCHK53 !***SUBSIDIARY !***PURPOSE Quick check for CHER2K and CSYR2K. !***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 CHER2K and CSYR2K. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CHER2K, CMAKE3, CMMCH, CSYR2K, LCE, LCERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CCHK53 ! .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) REAL RZERO, RONE ! .. Scalar Arguments .. PARAMETER ( RZERO = 0.0, RONE = 1.0 ) LOGICAL FATAL REAL EPS, THRESH integer KPRINT, NALF, NBET, NIDIM, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME COMPLEX AA( NMAX*NMAX ), AB( 2*NMAX*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 ) ! .. Local Scalars .. integer IDIM( NIDIM ) COMPLEX ALPHA, ALS, BETA, BETS REAL ERR, ERRMAX, RBETA, RBETS integer I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, & K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, & LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NERR, NS LOGICAL CONJ, FTL, NULL, RESET, TRAN, UPPER CHARACTER*1 TRANS, TRANSS, UPLO, TRANST, UPLOS ! .. Local Arrays .. CHARACTER*2 ICHU, ICHT ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LCE, LCERES ! .. External Subroutines .. EXTERNAL LCE, LCERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL CHER2K, CSYR2K, CMAKE3, CMMCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN !***FIRST EXECUTABLE STATEMENT CCHK53 DATA ICHU/'UL'/, ICHT/'NC'/ ! CONJ = SNAME( 2: 3 ) == 'HE' NARGS = 12 NC = 0 RESET = .TRUE. ! ERRMAX = RZERO DO 130 IN = 1, NIDIM ! Set LDC to 1 more than minimum value if room. N = IDIM( IN ) LDC = N if ( LDC < NMAX ) & ! Skip tests if not enough room. LDC = LDC + 1 if ( LDC > NMAX ) & GO TO 130 ! LCC = LDC*N DO 120 IK = 1, NIDIM ! K = IDIM( IK ) DO 110 ICT = 1, 2 TRANS = ICHT( ICT: ICT ) TRAN = TRANS == 'C' if ( TRAN .and. .NOT.CONJ ) & TRANS = 'T' if ( TRAN ) then MA = K NA = N else MA = N 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 110 ! ! Generate the matrix A. ! LAA = LDA*NA if ( TRAN ) then call CMAKE3( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, & LDA, RESET, ZERO ) else call CMAKE3( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, & LDA, RESET, ZERO ) ! ! Generate the matrix B. ! end if LDB = LDA LBB = LAA if ( TRAN ) then call CMAKE3( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), & 2*NMAX, BB, LDB, RESET, ZERO ) else call CMAKE3( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), & NMAX, BB, LDB, RESET, ZERO ) ! end if DO 100 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) ! UPPER = UPLO == 'U' DO 90 IA = 1, NALF ! ALPHA = ALF( IA ) DO 80 IB = 1, NBET BETA = BET( IB ) if ( CONJ ) then RBETA = REAL( BETA ) BETA = CMPLX( RBETA, RZERO ) end if NULL = N <= 0 if ( CONJ ) & NULL = NULL.OR.( ( K <= 0.OR.ALPHA == & ! ! Generate the matrix C. ! ZERO ) .and. RBETA == RONE ) call CMAKE3( SNAME( 2: 3 ), UPLO, ' ', N, N, C, & ! NMAX, CC, LDC, RESET, ZERO ) ! ! Save every datum before calling the subroutine. ! NC = NC + 1 UPLOS = UPLO TRANSS = TRANS 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 if ( CONJ ) then RBETS = RBETA else BETS = BETA end if DO 30 I = 1, LCC CS( I ) = CC( I ) 30 continue ! ! Call the subroutine. ! LDCS = LDC if ( CONJ ) then call CHER2K( UPLO, TRANS, N, K, ALPHA, AA, & LDA, BB, LDB, RBETA, CC, LDC ) else call CSYR2K( UPLO, TRANS, N, K, ALPHA, AA, & LDA, BB, LDB, BETA, CC, LDC ) ! ! Check if error-exit was taken incorrectly. ! end if if ( NUMXER(NERR) /= 0 ) then if ( kprint >= 2 ) then write ( NOUT, FMT = 9992 ) end if FATAL = .TRUE. ! ! See what data changed inside subroutines. ! end if ISAME( 1 ) = UPLOS == UPLO ISAME( 2 ) = TRANSS == TRANS ISAME( 3 ) = NS == N ISAME( 4 ) = KS == K ISAME( 5 ) = ALS == ALPHA ISAME( 6 ) = LCE( AS, AA, LAA ) ISAME( 7 ) = LDAS == LDA ISAME( 8 ) = LCE( BS, BB, LBB ) ISAME( 9 ) = LDBS == LDB if ( CONJ ) then ISAME( 10 ) = RBETS == RBETA else ISAME( 10 ) = BETS == BETA end if if ( NULL ) then ISAME( 11 ) = LCE( CS, CC, LCC ) else ISAME( 11 ) = LCERES( 'HE', UPLO, N, N, CS, & CC, LDC ) end if ! ! If data was incorrectly changed, report and ! return. ! ISAME( 12 ) = 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 ! ! Check the result column by column. ! if ( .NOT.NULL ) then if ( CONJ ) then TRANST = 'C' else TRANST = 'T' end if JJAB = 1 JC = 1 DO 70 J = 1, N if ( UPPER ) then JJ = 1 LJ = J else JJ = J LJ = N - J + 1 end if if ( TRAN ) then DO 50 I = 1, K W( I ) = ALPHA*AB( ( J - 1 )*2* & NMAX + K + I ) if ( CONJ ) then W( K + I ) = CONJG( ALPHA )* & AB( ( J - 1 )*2* & NMAX + I ) else W( K + I ) = ALPHA* & AB( ( J - 1 )*2* & NMAX + I ) end if 50 continue FTL = .FALSE. call CMMCH( TRANST, 'N', LJ, 1, 2*K, & ONE, AB( JJAB ), 2*NMAX, W, & 2*NMAX, BETA, C( JJ, J ), & NMAX, CT, G, CC( JC ), LDC, & EPS, ERR, FTL, NOUT, & .TRUE., kprint ) else DO 60 I = 1, K if ( CONJ ) then W( I ) = ALPHA*CONJG( AB( ( K + & I - 1 )*NMAX + J ) ) W( K + I ) = CONJG( ALPHA* & AB( ( I - 1 )*NMAX + & J ) ) else W( I ) = ALPHA*AB( ( K + I - 1 )* & NMAX + J ) W( K + I ) = ALPHA* & AB( ( I - 1 )*NMAX + & J ) end if 60 continue FTL = .FALSE. call CMMCH( 'N', 'N', LJ, 1, 2*K, ONE, & AB( JJ ), NMAX, W, 2*NMAX, & BETA, C( JJ, J ), NMAX, CT, & G, CC( JC ), LDC, EPS, ERR, & FTL, NOUT, .TRUE.,KPRINT) end if if ( UPPER ) then JC = JC + LDC else JC = JC + LDC + 1 if ( TRAN ) & JJAB = JJAB + 2*NMAX end if ERRMAX = max ( ERRMAX, ERR ) if ( FTL ) then FATAL = .TRUE. if ( kprint >= 3 ) then write ( NOUT, FMT = 9996 )SNAME if ( CONJ ) then write ( NOUT, FMT = 9994 )NC, SNAME, & UPLO, TRANS, N, K, ALPHA, & LDA, LDB, RBETA, LDC else write ( NOUT, FMT = 9993 )NC, SNAME, & UPLO, TRANS, N, K, ALPHA, & LDA, LDB, BETA, LDC end if end if end if 70 continue end if 80 continue 90 continue 100 continue 110 continue 120 continue ! ! Report result. ! 130 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:' ) 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), & '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1, & ', C,', I3, ') .' ) 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), & '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, & ',', F4.1, '), C,', I3, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of CCHK53. ! '******' ) end subroutine CCHK62 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, & Y, YY, YS, YT, G, Z) !! CCHK62 !***SUBSIDIARY !***PURPOSE Quick check for CHER2 and CHPR2. !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for CHER2 and CHPR2. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CHER2, CHPR2, CMAKE2, CMVCH, LCE, LCERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CCHK62 ! .. Parameters .. COMPLEX ZERO, HALF, ONE PARAMETER ( ZERO = ( 0.0, 0.0 ), HALF = ( 0.5, 0.0 ), & ONE = ( 1.0, 0.0 ) ) REAL RZERO ! .. Scalar Arguments .. PARAMETER ( RZERO = 0.0 ) LOGICAL FATAL REAL EPS, THRESH integer INCMAX, KPRINT, NALF, NIDIM, NINC, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), X( NMAX ), XS( NMAX*INCMAX ), & XX( NMAX*INCMAX ), Y( NMAX ), & YS( NMAX*INCMAX ), YT( NMAX ), & YY( NMAX*INCMAX ), Z( NMAX, 2 ) REAL G( NMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ), INC( NINC ) COMPLEX ALPHA, ALS, TRANSL REAL ERR, ERRMAX integer I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, & IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, & NARGS, NC, NERR, NS LOGICAL FTL, FULL, NULL, PACKED, RESET, UPPER CHARACTER*1 UPLO, UPLOS ! .. Local Arrays .. CHARACTER*2 ICH COMPLEX W( 2 ) ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LCE, LCERES ! .. External Subroutines .. EXTERNAL LCE, LCERES ! .. Intrinsic Functions .. EXTERNAL CHER2, CHPR2, CMAKE2, CMVCH ! .. Data statements .. INTRINSIC ABS, CONJG, MAX !***FIRST EXECUTABLE STATEMENT CCHK62 DATA ICH/'UL'/ FULL = SNAME( 3: 3 ) == 'E' ! Define the number of arguments. PACKED = SNAME( 3: 3 ) == 'P' if ( FULL ) then NARGS = 9 else if ( PACKED ) then NARGS = 8 ! end if NC = 0 RESET = .TRUE. ! ERRMAX = RZERO DO 140 IN = 1, NIDIM ! Set LDA to 1 more than minimum value if room. N = IDIM( IN ) LDA = N if ( LDA < NMAX ) & ! Skip tests if not enough room. LDA = LDA + 1 if ( LDA > NMAX ) & GO TO 140 if ( PACKED ) then LAA = ( N*( N + 1 ) )/2 else LAA = LDA*N end if DO 130 IC = 1, 2 UPLO = ICH( IC: IC ) UPPER = UPLO == 'U' DO 120 IX = 1, NINC INCX = INC( IX ) ! ! Generate the vector X. ! LX = ABS( INCX )*N TRANSL = HALF call CMAKE2( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), & 0, N - 1, RESET, TRANSL ) if ( N > 1 ) then X( N/2 ) = ZERO XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO end if DO 110 IY = 1, NINC INCY = INC( IY ) ! ! Generate the vector Y. ! LY = ABS( INCY )*N TRANSL = ZERO call CMAKE2( 'GE', ' ', ' ', 1, N, Y, 1, YY, & ABS( INCY ), 0, N - 1, RESET, TRANSL ) if ( N > 1 ) then Y( N/2 ) = ZERO YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO end if DO 100 IA = 1, NALF ALPHA = ALF( IA ) ! ! Generate the matrix A. ! NULL = N <= 0.OR.ALPHA == ZERO TRANSL = ZERO call CMAKE2( SNAME( 2: 3 ), UPLO, ' ', N, N, A, & NMAX, AA, LDA, N - 1, N - 1, RESET, & TRANSL ) ! ! Save every datum before calling the subroutine. ! NC = NC + 1 UPLOS = UPLO NS = N ALS = ALPHA AS(1:laa) = AA(1:laa) LDAS = LDA DO 20 I = 1, LX XS( I ) = XX( I ) 20 continue INCXS = INCX DO 30 I = 1, LY YS( I ) = YY( I ) 30 continue ! ! Call the subroutine. ! INCYS = INCY if ( FULL ) then call CHER2( UPLO, N, ALPHA, XX, INCX, YY, INCY, & AA, LDA ) else if ( PACKED ) then call CHPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, & AA ) ! ! Check if error-exit was taken incorrectly. ! end if if ( NUMXER(NERR) /= 0 ) then if ( kprint >= 2 ) then write ( NOUT, FMT = 9992 ) end if FATAL = .TRUE. ! ! See what data changed inside subroutines. ! end if ISAME( 1 ) = UPLO == UPLOS ISAME( 2 ) = NS == N ISAME( 3 ) = ALS == ALPHA ISAME( 4 ) = LCE( XS, XX, LX ) ISAME( 5 ) = INCXS == INCX ISAME( 6 ) = LCE( YS, YY, LY ) ISAME( 7 ) = INCYS == INCY if ( NULL ) then ISAME( 8 ) = LCE( AS, AA, LAA ) else ISAME( 8 ) = LCERES( SNAME( 2: 3 ), UPLO, N, N, & AS, AA, LDA ) end if if ( .NOT.PACKED ) then ISAME( 9 ) = LDAS == LDA ! ! 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 column by column. ! if ( .NOT.NULL ) then if ( INCX > 0 ) then DO 50 I = 1, N Z( I, 1 ) = X( I ) 50 continue else DO 60 I = 1, N Z( I, 1 ) = X( N - I + 1 ) 60 continue end if if ( INCY > 0 ) then Z(1:n,2) = Y(1:n) else DO I = 1, N Z( I, 2 ) = Y( N - I + 1 ) end do end if JA = 1 DO 90 J = 1, N W( 1 ) = ALPHA*CONJG( Z( J, 2 ) ) W( 2 ) = CONJG( ALPHA )*CONJG( Z( J, 1 ) ) if ( UPPER ) then JJ = 1 LJ = J else JJ = J LJ = N - J + 1 end if call CMVCH( 'N', LJ, 2, ONE, Z( JJ, 1 ), & NMAX, W, 1, ONE, A( JJ, J ), 1, & YT, G, AA( JA ), EPS, ERR, FTL, & NOUT, .TRUE., kprint ) if ( FULL ) then if ( UPPER ) then JA = JA + LDA else JA = JA + LDA + 1 end if else JA = JA + LJ end if ERRMAX = max ( ERRMAX, ERR ) 90 continue end if if ( FTL ) then FATAL = .TRUE. if ( kprint >= 3 ) then write ( NOUT, FMT = 9995 )J write ( NOUT, FMT = 9996 )SNAME if ( FULL ) then write ( NOUT, FMT = 9993 )NC, SNAME, & UPLO, N, ALPHA, INCX, & INCY, LDA else if ( PACKED ) then write ( NOUT, FMT = 9994 )NC, SNAME, & UPLO, N, ALPHA, INCX, INCY end if end if ! end if ! 100 continue ! 110 continue ! 120 continue ! 130 continue ! ! Report result. ! 140 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( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', & F4.1, '), X,', I2, ', Y,', I2, ', AP) ', & ' .' ) 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',(', F4.1, ',', & F4.1, '), X,', I2, ', Y,', I2, ', A,', I3, ') ', & ' .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & '******' ) end !! CCHKE2 !***SUBSIDIARY !***PURPOSE Test the error exits from the Level 2 Blas. !***LIBRARY SLATEC (BLAS) !***AUTHOR Du Croz, J. J., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! Tests the error exits from the Level 2 Blas. ! ALPHA, BETA, A, X and Y should not need to be defined. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CGBMV, CGEMV, CGERC, CGERU, CHBMV, CHEMV, CHER, ! CHER2, CHKXER, CHPMV, CHPR, CHPR2, CTBMV, CTBSV, ! CTPMV, CTPSV, CTRMV, CTRSV, XERCLR, XERDMP, XGETF, ! XSETF !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CCHKE2 ! .. Scalar Arguments .. subroutine CCHKE2 (ISNUM, SRNAMT, NOUT, KPRINT, FATAL) LOGICAL FATAL integer ISNUM, KPRINT, NOUT ! .. Scalars in Common .. CHARACTER*6 SRNAMT ! .. Local Scalars .. integer INFOT COMPLEX ALPHA, BETA REAL RALPHA ! .. Local Arrays .. integer KONTRL ! .. External Subroutines .. COMPLEX A( 1, 1), X( 1), Y( 1) EXTERNAL CGBMV, CGEMV, CGERC, CGERU, CHBMV, CHEMV, CHER, & CHER2, CHKXER, CHPMV, CHPR, CHPR2, CTBMV, & !***FIRST EXECUTABLE STATEMENT CCHKE2 CTBSV, CTPMV, CTPSV, CTRMV, CTRSV call XGETF (KONTRL) if ( kprint <= 2 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, & 90, 100, 110, 120, 130, 140, 150, 160, & 170 )ISNUM 10 INFOT = 1 call xerclr call CGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call CGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 180 20 INFOT = 1 call xerclr call CGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call CGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 13 call xerclr call CGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 180 30 INFOT = 1 call xerclr call CHEMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CHEMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CHEMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CHEMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CHEMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 180 40 INFOT = 1 call xerclr call CHBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CHBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CHBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CHBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call CHBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CHBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 180 50 INFOT = 1 call xerclr call CHPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CHPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CHPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CHPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 180 60 INFOT = 1 call xerclr call CTRMV( '/', 'N', 'N', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CTRMV( 'U', '/', 'N', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CTRMV( 'U', 'N', '/', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CTRMV( 'U', 'N', 'N', -1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRMV( 'U', 'N', 'N', 2, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call CTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 180 70 INFOT = 1 call xerclr call CTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CTBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CTBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CTBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CTBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 180 80 INFOT = 1 call xerclr call CTPMV( '/', 'N', 'N', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CTPMV( 'U', '/', 'N', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CTPMV( 'U', 'N', '/', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CTPMV( 'U', 'N', 'N', -1, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CTPMV( 'U', 'N', 'N', 0, A, X, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 180 90 INFOT = 1 call xerclr call CTRSV( '/', 'N', 'N', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CTRSV( 'U', '/', 'N', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CTRSV( 'U', 'N', '/', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CTRSV( 'U', 'N', 'N', -1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRSV( 'U', 'N', 'N', 2, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call CTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 180 100 INFOT = 1 call xerclr call CTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CTBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CTBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CTBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CTBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 180 110 INFOT = 1 call xerclr call CTPSV( '/', 'N', 'N', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CTPSV( 'U', '/', 'N', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CTPSV( 'U', 'N', '/', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CTPSV( 'U', 'N', 'N', -1, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CTPSV( 'U', 'N', 'N', 0, A, X, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 180 120 INFOT = 1 call xerclr call CGERC( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CGERC( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CGERC( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CGERC( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CGERC( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 180 130 INFOT = 1 call xerclr call CGERU( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CGERU( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CGERU( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CGERU( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CGERU( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 180 140 INFOT = 1 call xerclr call CHER( '/', 0, RALPHA, X, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CHER( 'U', -1, RALPHA, X, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CHER( 'U', 0, RALPHA, X, 0, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CHER( 'U', 2, RALPHA, X, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 180 150 INFOT = 1 call xerclr call CHPR( '/', 0, RALPHA, X, 1, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CHPR( 'U', -1, RALPHA, X, 1, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CHPR( 'U', 0, RALPHA, X, 0, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 180 160 INFOT = 1 call xerclr call CHER2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CHER2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CHER2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CHER2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CHER2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 180 170 INFOT = 1 call xerclr call CHPR2( '/', 0, ALPHA, X, 1, Y, 1, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CHPR2( 'U', -1, ALPHA, X, 1, Y, 1, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CHPR2( 'U', 0, ALPHA, X, 0, Y, 1, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CHPR2( 'U', 0, ALPHA, X, 1, Y, 0, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) 180 if ( kprint >= 2 ) then call XERDMP if ( .NOT. FATAL ) then write ( NOUT, FMT = 9999 )SRNAMT else write ( NOUT, FMT = 9998 )SRNAMT end if end if call XSETF (KONTRL) return 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', & '**' ) end !! CCHKE3 !***SUBSIDIARY !***PURPOSE Test the error exits from the Level 3 Blas. !***LIBRARY SLATEC (BLAS) !***AUTHOR Dongarra, J. J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) !***DESCRIPTION ! ! Tests the error exits from the Level 3 Blas. ! ALPHA, BETA, A, X and Y should not need to be defined. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CGEMM, CHEMM, CHER2K, CHERK, CHKXER, CSYMM, CSYR2K, ! CSYRK, CTRMM, CTRSM, XERCLR, XERDMP, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CCHKE3 ! .. Scalar Arguments .. subroutine CCHKE3 (ISNUM, SRNAMT, NOUT, KPRINT, FATAL) LOGICAL FATAL integer ISNUM, KPRINT, NOUT ! .. Scalars in Common .. CHARACTER*6 SRNAMT ! .. Local Scalars .. integer INFOT COMPLEX ALPHA, BETA REAL RALPHA, RBETA ! .. Local Arrays .. integer KONTRL ! .. External Subroutines .. COMPLEX A( 2, 1), B( 2, 1), C( 2, 1) EXTERNAL CGEMM, CHEMM, CHER2K, CHERK, CHKXER, CSYMM, & !***FIRST EXECUTABLE STATEMENT CCHKE3 CSYR2K, CSYRK, CTRMM, CTRSM call XGETF (KONTRL) if ( kprint <= 2 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, & 90 )ISNUM 10 INFOT = 1 call xerclr call CGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 1 call xerclr call CGEMM( '/', 'C', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 1 call xerclr call CGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CGEMM( 'C', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CGEMM( 'N', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CGEMM( 'C', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CGEMM( 'C', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CGEMM( 'C', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CGEMM( 'T', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CGEMM( 'N', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CGEMM( 'C', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CGEMM( 'C', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CGEMM( 'C', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CGEMM( 'T', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CGEMM( 'N', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CGEMM( 'C', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CGEMM( 'C', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CGEMM( 'C', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CGEMM( 'T', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call CGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call CGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call CGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call CGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call CGEMM( 'C', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call CGEMM( 'C', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call CGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call CGEMM( 'T', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call CGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CGEMM( 'N', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CGEMM( 'C', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CGEMM( 'T', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CGEMM( 'C', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 13 call xerclr call CGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 13 call xerclr call CGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 13 call xerclr call CGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 13 call xerclr call CGEMM( 'C', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 13 call xerclr call CGEMM( 'C', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 13 call xerclr call CGEMM( 'C', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 13 call xerclr call CGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 13 call xerclr call CGEMM( 'T', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 13 call xerclr call CGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 100 20 INFOT = 1 call xerclr call CHEMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CHEMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CHEMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CHEMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CHEMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CHEMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CHEMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CHEMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CHEMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CHEMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CHEMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CHEMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CHEMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CHEMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call CHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call CHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call CHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call CHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 100 30 INFOT = 1 call xerclr call CSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call CSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call CSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call CSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call CSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 100 40 INFOT = 1 call xerclr call CTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRMM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRMM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRMM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRMM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRMM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRMM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRMM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRMM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRMM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRMM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRMM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRMM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 100 50 INFOT = 1 call xerclr call CTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRSM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRSM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRSM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRSM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call CTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRSM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRSM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRSM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRSM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call CTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRSM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRSM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRSM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRSM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call CTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 100 60 INFOT = 1 call xerclr call CHERK( '/', 'N', 0, 0, RALPHA, A, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CHERK( 'U', 'T', 0, 0, RALPHA, A, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CHERK( 'U', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CHERK( 'U', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CHERK( 'L', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CHERK( 'L', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CHERK( 'U', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CHERK( 'U', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CHERK( 'L', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CHERK( 'L', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CHERK( 'U', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CHERK( 'U', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CHERK( 'L', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CHERK( 'L', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CHERK( 'U', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CHERK( 'U', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CHERK( 'L', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CHERK( 'L', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 100 70 INFOT = 1 call xerclr call CSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CSYRK( 'U', 'C', 0, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call CSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 100 80 INFOT = 1 call xerclr call CHER2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CHER2K( 'U', 'T', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CHER2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CHER2K( 'U', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CHER2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CHER2K( 'L', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CHER2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CHER2K( 'U', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CHER2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CHER2K( 'L', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CHER2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CHER2K( 'U', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CHER2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CHER2K( 'L', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CHER2K( 'U', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CHER2K( 'L', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call CHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call CHER2K( 'U', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call CHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call CHER2K( 'L', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 100 90 INFOT = 1 call xerclr call CSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call CSYR2K( 'U', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call CSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call CSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call CSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call CSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call CSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call CSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call CSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call CSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) ! call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) 100 if ( kprint >= 2 ) then call XERDMP if ( .NOT.FATAL ) then write ( NOUT, FMT = 9999 )SRNAMT else write ( NOUT, FMT = 9998 )SRNAMT end if end if call XSETF (KONTRL) return 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', & '**' ) end !! CCHQC !***PURPOSE Quick check for CCHDC. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! QUICK CHECK FOR LINPACK SUBROUTINE CCHDC. ! ! THE CHOLESKY FACTORIZATION OF MATRIX A IS COMPARED TO ! THE STORED PRE-COMPUTED FACTORIZATION OF A (ENTERED ! WITH A DATA STATEMENT). FAILURE OF THE TEST OCCURS WHEN ! AGREEMENT TO 3 SIGNIFICANT DIGITS IS NOT ACHIEVED AND AN ! ERROR MESSAGE IS PRINTED. ! ! THE INTEGER VALUES OF JPVT AND INFO ARE SIMILARLY TESTED. ! LACK OF AGREEMENT RESULTS IN AN ERROR MESSAGE. A SUMMARY ! LINE IS ALWAYS PRINTED. ! ! NO INPUT ARGUMENTS ARE REQUIRED. ON RETURN, NERR (INTEGER ! TYPE) CONTAINS THE TOTAL COUNT OF ALL FAILURES DETECTED. ! !***ROUTINES CALLED CCHDC !***REVISION HISTORY (YYMMDD) ! 801027 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if and cleaned up ! FORMATs. (RWC) !***END PROLOGUE CCHQC subroutine CCHQC (LUN, KPRINT, NERR) COMPLEX A(4,4),WORK(4),AT(5,4),AF(4,4) integer LDA,P,JPVT(4),JOB,INFO,JPVTT(4),I,J,INFOC,JPVTC(4) CHARACTER*20 KFAIL integer INDX REAL DELX DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA JPVT/0,-1,1,0/ DATA AF/(1.73205E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,-.57735E0),(1.91485E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(1.41421E0,0.E0),(0.E0,1.E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,-.70711E0),(1.22475E0,0.E0)/ DATA INFOC/4/ DATA JPVTC/3,4,1,2/ !***FIRST EXECUTABLE STATEMENT CCHQC DATA KFAIL/'FACTORING JPVT INFO '/ JOB = 1 LDA = 5 P = 4 ! ! FORM AT AND JPVTT. ! NERR = 0 DO J=1,P JPVTT(J) = JPVT(J) AT(1:p,J) = A(1:p,J) end do ! ! TEST CCHDC. ! call CCHDC(AT,LDA,P,WORK,JPVTT,JOB,INFO) INDX = 0 DO 40 J=1,P DO 30 I=1,P DELX =ABS(REAL(AT(I,J)-AF(I,J)))+ABS(AIMAG(AT(I,J)-AF(I,J))) if ( DELX > .0001) INDX=INDX+1 30 continue 40 continue if ( INDX /= 0 ) then write (LUN,201) KFAIL(1:9) NERR = NERR + 1 end if INDX = 0 DO 60 I=1,P if ( JPVTT(I) /= JPVTC(I)) INDX=INDX+1 60 continue if ( INDX /= 0 ) then write (LUN,201) KFAIL(11:14) NERR = NERR + 1 end if if ( INFO /= INFOC ) then write (LUN,201) KFAIL(16:19) NERR = NERR + 1 end if if ( KPRINT >= 2 .OR. NERR /= 0) write (LUN,200) NERR return 200 FORMAT (/' * CCHQC - TEST FOR CCHDC FOUND ', I1, ' ERRORS.'/ & 6X, '(NO TEST FOR CCHUD, CCHDD OR CCHEX)'/) 201 FORMAT (/' *** CCHDC FAILURE - ERROR IN ', A) end !! CDF !***SUBSIDIARY !***PURPOSE Quick check for SLATEC routines CDRIV1, CDRIV2 and CDRIV3. !***LIBRARY SLATEC (SDRIVE) !***CATEGORY I1A2, I1A1B !***TYPE COMPLEX (SDF-S, DDF-D, CDF-C) !***KEYWORDS CDRIV1, CDRIV2, CDRIV3, QUICK CHECK, SDRIVE !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***SEE ALSO CDQCK !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 890405 DATE WRITTEN ! 890405 Revised to meet SLATEC standards. !***END PROLOGUE CDF subroutine CDF (N, T, Y, YP) REAL T COMPLEX ALFA, Y(*), YP(*) !***FIRST EXECUTABLE STATEMENT CDF integer N ALFA = Y(N+1) YP(1) = 1.E0 + ALFA*(Y(2) - Y(1)) - Y(1)*Y(3) YP(2) = ALFA*(Y(1) - Y(2)) - Y(2)*Y(3) YP(3) = 1.E0 - Y(3)*(Y(1) + Y(2)) return end !! CDQAG !***PURPOSE Quick check for DQAG. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (CQAG-S, CDQAG-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED d1mach, DF1G, DF2G, DF3G, DPRIN, DQAG !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) !***END PROLOGUE CDQAG ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CDQAG (LUN, KPRINT, IPASS) double precision A,ABSERR,B,d1mach,EPMACH,EPSABS,EPSREL,ERROR, & EXACT1,EXACT2,EXACT3,DF1G,DF2G,DF3G,PI,RESULT,UFLOW,WORK integer IER,IP,IPASS,IWORK,KEY,KPRINT,LAST,LENW,LIMIT, & NEVAL dimension IERV(2),IWORK(100),WORK(400) EXTERNAL DF1G,DF2G,DF3G DATA PI/0.31415926535897932D+01/ DATA EXACT1/0.1154700538379252D+01/ DATA EXACT2/0.11780972450996172D+00/ !***FIRST EXECUTABLE STATEMENT CDQAG DATA EXACT3/0.1855802D+02/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1DQAG QUICK CHECK''/)') ipass = 1 LIMIT = 100 LENW = LIMIT*4 EPSABS = 0.0D+00 EPMACH = d1mach(4) KEY = 6 EPSREL = max ( SQRT(EPMACH),0.1D-07) A = 0.0D+00 B = 0.1D+01 call DQAG(DF1G,A,B,EPSABS,EPSREL,KEY,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT1-RESULT) if ( IER == 0 .and. ERROR <= ABSERR.AND.ABSERR <= EPSREL*ABS(EXACT1)) & IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 1 ! call DPRIN(LUN,0,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) LIMIT = 1 LENW = LIMIT*4 B = PI*0.2D+01 call DQAG(DF2G,A,B,EPSABS,EPSREL,KEY,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 2 OR 1 ! call DPRIN(LUN,1,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,1) UFLOW = d1mach(1) LIMIT = 100 LENW = LIMIT*4 call DQAG(DF2G,A,B,UFLOW,0.0D+00,KEY,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 if ( IER == 2.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 3 OR 1 ! call DPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,2) B = 0.1D+01 call DQAG(DF3G,A,B,EPSABS,EPSREL,1,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 if ( IER == 3.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 6 ! call DPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,2) LENW = 1 call DQAG(DF1G,A,B,EPSABS,EPSREL,KEY,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 6 .and. RESULT == 0.0D+00.AND.ABSERR == 0.0D+00.AND. & NEVAL == 0 .and. LAST == 0) IP = 1 if ( IP == 0) ipass = 0 ! call DPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CDQAG FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CDQAG PASSED''/)') end if end if return end !! CDQAGI !***PURPOSE Quick check for DQAGI. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (CQAGI-S, CDQAGI-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED d1mach, DPRIN, DQAGI, DT0, DT1, DT2, DT3, DT4, DT5 !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891009 Removed unreferenced variables. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) !***END PROLOGUE CDQAGI ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CDQAGI (LUN, KPRINT, IPASS) double precision ABSERR,BOUND,d1mach,EPMACH,EPSABS, & EPSREL,ERROR,EXACT0,EXACT1,EXACT2,EXACT3,EXACT4, & OFLOW,RESULT,DT0,DT1,DT2,DT3,DT4,DT5,UFLOW,WORK integer IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,LUN,NEVAL dimension WORK(800),IWORK(200),IERV(4) EXTERNAL DT0,DT1,DT2,DT3,DT4,DT5 DATA EXACT0/2.0D+00/,EXACT1/0.115470066904D1/ DATA EXACT2/0.909864525656D-02/ DATA EXACT3/0.31415926535897932D+01/ !***FIRST EXECUTABLE STATEMENT CDQAGI DATA EXACT4/0.19984914554328673D+04/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1DQAGI QUICK CHECK''/)') ipass = 1 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0D+00 EPMACH = d1mach(4) EPSREL = max ( SQRT(EPMACH),0.1D-07) BOUND = 0.0D+00 INF = 1 call DQAGI(DT0,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) ERROR = ABS(RESULT-EXACT0) IERV(1) = IER IP = 0 if ( IER == 0 .and. ERROR <= EPSREL*ABS(EXACT0)) & IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 1 ! call DPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) call DQAGI(DT1,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, & 1,4,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 2 OR 4 OR 1 ! call DPRIN(LUN,1,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) UFLOW = d1mach(1) call DQAGI(DT2,BOUND,INF,UFLOW,0.0D+00,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 if ( IER == 2.OR.IER == 4.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 3 OR 4 OR 1 OR 2 ! call DPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,3) call DQAGI(DT3,BOUND,INF,UFLOW,0.0D+00,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4) = 2 IP = 0 if ( IER == 3.OR.IER == 4.OR.IER == 1.OR.IER == 2) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 4 OR 3 OR 1 OR 0 ! call DPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,4) call DQAGI(DT4,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 3 IERV(3) = 1 IERV(4) = 0 IP = 0 if ( IER == 4.OR.IER == 3.OR.IER == 1.OR.IER == 0) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 5 ! call DPRIN(LUN,4,KPRINT,IP,EXACT4,RESULT,ABSERR,NEVAL,IERV,4) OFLOW = d1mach(2) call DQAGI(DT5,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 5) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 6 ! call DPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) call DQAGI(DT1,BOUND,INF,EPSABS,0.0D+00,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 6 .and. RESULT == 0.0D+00.AND.ABSERR == 0.0D+00.AND. & NEVAL == 0 .and. LAST == 0) IP = 1 if ( IP == 0) ipass = 0 ! call DPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CDQAGI FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CDQAGI PASSED''/)') end if end if return end !! CDQAGP !***PURPOSE Quick check for DQAGP. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (CQAGP-S, CDQAGP-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED d1mach, DF1P, DF2P, DF3P, DF4P, DPRIN, DQAGP !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) !***END PROLOGUE CDQAGP ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CDQAGP (LUN, KPRINT, IPASS) double precision A,ABSERR,B,d1mach,EPMACH,EPSABS,EPSREL,ERROR, & EXACT1, & EXACT2,EXACT3,DF1P,DF2P,DF3P,DF4P,OFLOW,POINTS,P1,P2,RESULT, & UFLOW,WORK integer IER,IP,IPASS,IWORK,KPRINT,LAST,LENIW,LENW,LIMIT,LUN, & NEVAL,NPTS2 dimension IERV(4),IWORK(205),POINTS(5),WORK(405) EXTERNAL DF1P,DF2P,DF3P,DF4P DATA EXACT1/0.4285277667368085D+01/ DATA EXACT2/0.909864525656D-2/ DATA EXACT3/0.31415926535897932D+01/ DATA P1/0.1428571428571428D+00/ !***FIRST EXECUTABLE STATEMENT CDQAGP DATA P2/0.6666666666666667D+00/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1DQAGP QUICK CHECK''/)') ipass = 1 NPTS2 = 4 LIMIT = 100 LENIW = LIMIT*2+NPTS2 LENW = LIMIT*4+NPTS2 EPSABS = 0.0D+00 EPMACH = d1mach(4) EPSREL = max ( SQRT(EPMACH),0.1D-07) A = 0.0D+00 B = 0.1D+01 POINTS(1) = P1 POINTS(2) = P2 call DQAGP(DF1P,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK) ERROR = ABS(RESULT-EXACT1) IERV(1) = IER IP=0 if ( IER == 0 .and. ERROR <= EPSREL*ABS(EXACT1)) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 1 ! call DPRIN(LUN,0,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) LENIW = 10 LENW = LENIW*2-NPTS2 call DQAGP(DF1P,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 2, 4, 1 OR 3 ! call DPRIN(LUN,1,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) NPTS2 = 3 POINTS(1) = 0.1D+00 LENIW = LIMIT*2+NPTS2 LENW = LIMIT*4+NPTS2 UFLOW = d1mach(1) A = 0.1D+00 call DQAGP(DF2P,A,B,NPTS2,POINTS,UFLOW,0.0D+00,RESULT,ABSERR, & NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4) = 3 IP = 0 if ( IER == 2.OR.IER == 4.OR.IER == 1.OR.IER == 3) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 3 OR 4 OR 1 OR 2 ! call DPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,4) NPTS2 = 2 LENIW = LIMIT*2+NPTS2 LENW = LIMIT*4+NPTS2 A = 0.0D+00 B = 0.5D+01 call DQAGP(DF3P,A,B,NPTS2,POINTS,UFLOW,0.0D+00,RESULT,ABSERR, & NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4) = 2 IP = 0 if ( IER == 3.OR.IER == 4.OR.IER == 1.OR.IER == 2) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 5 ! call DPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,4) B = 0.1D+01 call DQAGP(DF4P,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 5) IP = 1 if ( IP == 0) ipass = 0 OFLOW = d1mach(2) ! ! TEST ON IER = 6 ! call DPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) NPTS2 = 5 LENIW = LIMIT*2+NPTS2 LENW = LIMIT*4+NPTS2 POINTS(1) = P1 POINTS(2) = P2 POINTS(3) = 0.3D+01 call DQAGP(DF1P,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 6 .and. RESULT == 0.0D+00.AND.ABSERR == 0.0D+00.AND. & NEVAL == 0 .and. LAST == 0) IP = 1 if ( IP == 0) ipass = 0 ! call DPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CDQAGP FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CDQAGP PASSED''/)') end if end if return end !! CDQAGS !***PURPOSE Quick check for DQAGS. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (CQAGS-S, CDQAGS-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED d1mach, DF0S, DF1S, DF2S, DF3S, DF4S, DF5S, DPRIN, ! DQAGS !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) ! 911114 Modified test on IER=4 to allow IER=5. (WRB) !***END PROLOGUE CDQAGS ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CDQAGS (LUN, KPRINT, IPASS) double precision A,ABSERR,B,d1mach,EPMACH,EPSABS, & EPSREL,ERROR,EXACT0,EXACT1,EXACT2,EXACT3,EXACT4, & DF0S,DF1S,DF2S,DF3S,DF4S,DF5S,OFLOW,RESULT,UFLOW,WORK integer IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,NEVAL dimension IERV(5),IWORK(200),WORK(800) EXTERNAL DF0S,DF1S,DF2S,DF3S,DF4S,DF5S DATA EXACT0/0.2D+01/ DATA EXACT1/0.115470066904D+01/ DATA EXACT2/0.909864525656D-02/ DATA EXACT3/0.31415926535897932D+01/ !***FIRST EXECUTABLE STATEMENT CDQAGS DATA EXACT4/0.19984914554328673D+04/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1DQAGS QUICK CHECK''/)') ipass = 1 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0D+00 EPMACH = d1mach(4) EPSREL = max ( SQRT(EPMACH),0.1D-07) A = 0.0D+00 B = 0.1D+01 call DQAGS(DF0S,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) ERROR = ABS(RESULT-EXACT0) IERV(1) = IER IP = 0 if ( IER == 0 .and. ERROR <= EPSREL*ABS(EXACT0)) & IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 1 ! call DPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) call DQAGS(DF1S,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, & 1,4,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 1)IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 2 OR 4 OR 1 ! call DPRIN(LUN,1,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) UFLOW = d1mach(1) A = 0.1D+00 call DQAGS(DF2S,A,B,UFLOW,0.0D+00,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 if ( IER == 2.OR.IER == 4.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 3 OR 4 OR 1 OR 2 ! call DPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,3) A = 0.0D+00 B = 0.5D+01 call DQAGS(DF3S,A,B,UFLOW,0.0D+00,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4) = 2 IP = 0 if ( IER == 3.OR.IER == 4.OR.IER == 1.OR.IER == 2) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 4, OR 5 OR 3 OR 1 OR 0 ! call DPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,4) B = 0.1D+01 call DQAGS(DF4S,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 5 IERV(3) = 3 IERV(4) = 1 IERV(5) = 0 IP = 0 if ( IER == 5.OR.IER == 4.OR.IER == 3.OR.IER == 1.OR.IER == 0) & IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 5 ! call DPRIN(LUN,4,KPRINT,IP,EXACT4,RESULT,ABSERR,NEVAL,IERV,5) OFLOW = d1mach(2) call DQAGS(DF5S,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 5) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 6 ! call DPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) call DQAGS(DF1S,A,B,EPSABS,0.0D+00,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 6 .and. RESULT == 0.0D+00.AND.ABSERR == 0.0D+00.AND. & NEVAL == 0 .and. LAST == 0) IP = 1 if ( IP == 0) ipass = 0 ! call DPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CDQAGS FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CDQAGS PASSED''/)') end if end if return end !! CDQAWC !***PURPOSE Quick check for DQAWC. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (CQAWC-S, CDQAWC-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED d1mach, DF0C, DF1C, DPRIN, DQAWC !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) !***END PROLOGUE CDQAWC ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CDQAWC (LUN, KPRINT, IPASS) double precision A,ABSERR,B,d1mach,EPMACH,EPSABS, & EPSREL,ERROR,EXACT0,EXACT1,DF0C,DF1C,C, & RESULT,UFLOW,WORK integer IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,NEVAL dimension WORK(800),IWORK(200),IERV(2) EXTERNAL DF0C,DF1C DATA EXACT0/-0.6284617285065624D+03/ !***FIRST EXECUTABLE STATEMENT CDQAWC DATA EXACT1/0.1855802D+01/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1DQAWC QUICK CHECK''/)') ipass = 1 C = 0.5D+00 A = -1.0D+00 B = 1.0D+00 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0D+00 EPMACH = d1mach(4) EPSREL = max ( SQRT(EPMACH),0.1D-07) call DQAWC(DF0C,A,B,C,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT0-RESULT) if ( IER == 0 .and. ERROR <= ABSERR.AND.ABSERR <= EPSREL*ABS(EXACT0)) & IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 1 ! call DPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) call DQAWC(DF0C,A,B,C,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,1,4,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 2 OR 1 ! call DPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) UFLOW = d1mach(1) call DQAWC(DF0C,A,B,C,UFLOW,0.0D+00,RESULT,ABSERR, & NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 if ( IER == 2.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 3 OR 1 ! call DPRIN(LUN,2,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,2) call DQAWC(DF1C,0.0D+00,B,C,UFLOW,0.0D+00,RESULT,ABSERR, & NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 if ( IER == 3.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 6 ! call DPRIN(LUN,3,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,2) EPSABS = 0.0D+00 EPSREL = 0.0D+00 call DQAWC(DF0C,A,B,C,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 6) IP = 1 if ( IP == 0) ipass = 0 ! call DPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CDQAWC FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CDQAWC PASSED''/)') end if end if return end !! CDQAWF !***PURPOSE Quick check for DQAWF. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (CQAWF-S, CDQAWF-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED d1mach, DF0F, DF1F, DPRIN, DQAWF !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) !***END PROLOGUE CDQAWF ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CDQAWF (LUN, KPRINT, IPASS) double precision A,ABSERR,d1mach,EPSABS,EPMACH, & ERROR,EXACT0,DF0F,DF1F,OMEGA,PI,RESULT,UFLOW,WORK integer IER,IP,IPASS,KPRINT,LENW,LIMIT,LIMLST,LST,NEVAL dimension IERV(4),IWORK(450),WORK(1425) EXTERNAL DF0F,DF1F DATA EXACT0/0.1422552162575912D+01/ !***FIRST EXECUTABLE STATEMENT CDQAWF DATA PI/0.31415926535897932D+01/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1DQAWF QUICK CHECK''/)') ipass = 1 MAXP1 = 21 LIMLST = 50 LIMIT = 200 LENIW = LIMIT*2+LIMLST LENW = LENIW*2+MAXP1*25 EPMACH = d1mach(4) EPSABS = max ( SQRT(EPMACH),0.1D-02) A = 0.0D+00 OMEGA = 0.8D+01 INTEGR = 2 call DQAWF(DF0F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, & IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT0-RESULT) if ( IER == 0 .and. ERROR <= ABSERR.AND.ABSERR <= EPSABS) & IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 1 ! call DPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) LIMLST = 3 LENIW = 403 LENW = LENIW*2+MAXP1*25 call DQAWF(DF0F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, & IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 3 OR 4 OR 1 OR 2 ! call DPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) LIMLST = 50 LENIW = LIMIT*2+LIMLST LENW = LENIW*2+MAXP1*25 UFLOW = d1mach(1) call DQAWF(DF1F,A,0.0D+00,1,UFLOW,RESULT,ABSERR,NEVAL, & IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4) = 2 IP = 0 if ( IER == 3.OR.IER == 4.OR.IER == 1.OR.IER == 2) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 6 ! call DPRIN(LUN,3,KPRINT,IP,PI,RESULT,ABSERR,NEVAL,IERV,4) LIMLST = 50 LENIW = 20 call DQAWF(DF0F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, & IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 6) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 7 ! call DPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) LIMLST = 50 LENIW = 52 LENW = LENIW*2+MAXP1*25 call DQAWF(DF0F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, & IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 7) IP = 1 if ( IP == 0) ipass = 0 ! call DPRIN(LUN,7,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CDQAWF FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CDQAWF PASSED''/)') end if end if return end !! CDQAWO !***PURPOSE Quick check for DQAWO. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (CQAWO-S, CDQAWO-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED d1mach, DF0O, DF1O, DF2O, DPRIN, DQAWO !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) !***END PROLOGUE CDQAWO ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CDQAWO (LUN, KPRINT, IPASS) double precision A,ABSERR,B,EPMACH,EPSABS, & EPSREL,ERROR,EXACT0,DF0O,DF1O,DF2O, & OFLOW,OMEGA,PI,RESULT,d1mach,UFLOW,WORK integer IER,IERV,INTEGR,IP,IPASS,IWORK,KPRINT,LAST,LENW,LUN, & MAXP1,NEVAL dimension WORK(1325),IWORK(400),IERV(4) EXTERNAL DF0O,DF1O,DF2O DATA EXACT0/0.1042872789432789D+05/ !***FIRST EXECUTABLE STATEMENT CDQAWO DATA PI/0.31415926535897932D+01/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1DQAWO QUICK CHECK''/)') ipass = 1 MAXP1 = 21 LENIW = 400 LENW = LENIW*2+MAXP1*25 EPSABS = 0.0D+00 EPMACH = d1mach(4) EPSREL = max ( SQRT(EPMACH),0.1D-07) A = 0.0D+00 B = PI OMEGA = 0.1D+01 INTEGR = 2 call DQAWO(DF0O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT0-RESULT) if ( IER == 0 .and. ERROR <= ABSERR.AND.ABSERR <= EPSREL*ABS(EXACT0)) & IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 1 ! call DPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) LENIW = 2 LENW = LENIW*2+MAXP1*25 call DQAWO(DF0O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 2 OR 4 OR 1 ! call DPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) UFLOW = d1mach(1) LENIW = 400 LENW = LENIW*2+MAXP1*25 call DQAWO(DF0O,A,B,OMEGA,INTEGR,UFLOW,0.0D+00,RESULT,ABSERR, & NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 if ( IER == 2.OR.IER == 4.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 3 OR 4 OR 1 OR 2 ! call DPRIN(LUN,2,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,3) B = 0.5D+01 OMEGA = 0.0D+00 INTEGR = 1 call DQAWO(DF1O,A,B,OMEGA,INTEGR,UFLOW,0.0D+00,RESULT,ABSERR, & NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4) = 2 IP = 0 if ( IER == 3.OR.IER == 4.OR.IER == 1.OR.IER == 2) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 5 ! call DPRIN(LUN,3,KPRINT,IP,PI,RESULT,ABSERR,NEVAL,IERV,4) B = 0.1D+01 OFLOW = d1mach(2) call DQAWO(DF2O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 5) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 6 ! call DPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) INTEGR = 3 call DQAWO(DF0O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 6 .and. RESULT == 0.0D+00.AND.ABSERR == 0.0D+00.AND. & NEVAL == 0 .and. LAST == 0) IP = 1 if ( IP == 0) ipass = 0 ! call DPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CDQAWO FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CDQAWO PASSED''/)') end if end if return end !! CDQAWS !***PURPOSE Quick check for DQAWS. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (CQAWS-S, CDQAWS-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED d1mach, DF0WS, DF1WS, DPRIN, DQAWS !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) !***END PROLOGUE CDQAWS ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CDQAWS (LUN, KPRINT, IPASS) double precision A,ABSERR,B,d1mach,EPMACH,EPSABS, & EPSREL,ERROR,EXACT0,EXACT1,DF0WS,DF1WS,ALFA,BETA, & RESULT,UFLOW,WORK integer IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,NEVAL,INTEGR dimension WORK(800),IWORK(200),IERV(2) EXTERNAL DF0WS,DF1WS DATA EXACT0/0.5350190569223644D+00/ !***FIRST EXECUTABLE STATEMENT CDQAWS DATA EXACT1/0.1998491554328673D+04/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1DQAWS QUICK CHECK''/)') ipass = 1 ALFA = -0.5D+00 BETA = -0.5D+00 INTEGR = 1 A = 0.0D+00 B = 0.1D+01 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0D+00 EPMACH = d1mach(4) EPSREL = max ( SQRT(EPMACH),0.1D-07) call DQAWS(DF0WS,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT0-RESULT) if ( IER == 0 .and. ERROR <= EPSREL*ABS(EXACT0)) & IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 1 ! call DPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) call DQAWS(DF0WS,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,2,8,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 2 OR 1 ! call DPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) UFLOW = d1mach(1) call DQAWS(DF0WS,A,B,ALFA,BETA,INTEGR,UFLOW,0.0D+00,RESULT,ABSERR, & NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 if ( IER == 2.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 3 OR 1 ! call DPRIN(LUN,2,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,2) call DQAWS(DF1WS,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 if ( IER == 3.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 6 ! call DPRIN(LUN,3,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,2) INTEGR = 0 call DQAWS(DF1WS,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 6) IP = 1 if ( IP == 0) ipass = 0 ! call DPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CDQAWS FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CDQAWS PASSED''/)') end if end if return end !! CDQCK !***PURPOSE Quick check for SLATEC routines CDRIV1, CDRIV2 and CDRIV3. !***LIBRARY SLATEC (SDRIVE) !***CATEGORY I1A2, I1A1B !***TYPE COMPLEX (SDQCK-S, DDQCK-D, CDQCK-C) !***KEYWORDS CDRIV1, CDRIV2, CDRIV3, QUICK CHECK, SDRIVE !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! For assistance in determining the cause of a failure of these ! routines contact C. D. Sutherland at commercial telephone number ! (505)667-6949, FTS telephone number 8-843-6949, or electronic mail ! address CDS@LANL.GOV . ! !***ROUTINES CALLED CDF, CDRIV1, CDRIV2, CDRIV3, R1MACH, XERCLR !***REVISION HISTORY (YYMMDD) ! 890405 DATE WRITTEN ! 890405 Revised to meet SLATEC standards. !***END PROLOGUE CDQCK subroutine CDQCK (LUN, KPRINT, IPASS) EXTERNAL CDF REAL EPS, EWT(1), HMAX, R1MACH, T, TOUT integer IERFLG, IERROR, IMPL, IPASS, KPRINT, LENIW, LENIWX, LENW, & LENWMX, LENWX, LIWMX, LUN, MINT, MITER, ML, MSTATE, MU, & MXORD, MXSTEP, N, NDE, NFE, NJE, NROOT, NSTATE, NSTEP, & NTASK, NX PARAMETER(HMAX = 15.E0, IERROR = 3, IMPL = 0, & LENWMX = 342, LIWMX = 53, MITER = 5, ML = 2, MU = 2, & MXORD = 5, MXSTEP = 1000, N = 3, NROOT = 0, NTASK = 1) COMPLEX ALFA, WORK(LENWMX), Y(N+1) integer IWORK(LIWMX) !***FIRST EXECUTABLE STATEMENT CDQCK DATA EWT(1) /.00001E0/ ALFA = (1.E0, 1.E0) EPS = R1MACH(4)**(1.E0/3.E0) ! Exercise CDRIV1 for problem ! with known solution. ipass = 1 Y(4) = ALFA T = 0.E0 Y(1) = 10.E0 Y(2) = 0.E0 Y(3) = 10.E0 TOUT = 10.E0 MSTATE = 1 LENW = 342 call CDRIV1 (N, T, Y, CDF, TOUT, MSTATE, EPS, WORK, LENW, IERFLG) NSTEP = WORK(LENW - (N + 50) + 3) NFE = WORK(LENW - (N + 50) + 4) NJE = WORK(LENW - (N + 50) + 5) if ( MSTATE == 2 ) then if ( ABS(0.620174E0 - ABS(Y(1))) <= EPS**(2.E0/3.E0) .and. & ABS(0.392232E0 - ABS(Y(2))) <= EPS**(2.E0/3.E0) .and. & ABS(1.E0 - ABS(Y(3))) <= EPS**(2.E0/3.E0) ) then if ( kprint == 2 ) then write (LUN, '('' CDRIV1:The solution determined met the expected values.'' //)') else if ( kprint == 3 ) then write (LUN, '('' CDRIV1:The solution determined met the expected values.'')') write (LUN, '('' The values of results are '')') write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, '(/)') end if else if ( kprint == 1 ) then write (LUN, '('' CDRIV1:The solution determined is not accurate enough.'' //)') else if ( kprint == 2 ) then write (LUN, '('' CDRIV1:The solution determined is not accurate enough.'')') write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) ' EPS = ', EPS write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(/)') end if ipass = 0 end if else if ( kprint == 1 ) then write (LUN, '('' While using CDRIV1, a solution was not obtained.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' While using CDRIV1, a solution was not obtained.'')') write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) & ' MSTATE = ', MSTATE, ', Error number = ', IERFLG write (LUN, *) ' N ', N, ', EPS ', EPS, ', LENW ', LENW write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(/)') end if ipass = 0 end if ! Run CDRIV1 with invalid input. call xerclr NX = 201 T = 0.E0 Y(1) = 10.E0 Y(2) = 0.E0 Y(3) = 10.E0 Y(4) = ALFA TOUT = 10.E0 MSTATE = 1 LENW = 342 call CDRIV1 (NX, T, Y, CDF, TOUT, MSTATE, EPS, WORK, LENW, IERFLG) if ( IERFLG == 21 ) then if ( kprint == 2 ) then write (LUN, '('' CDRIV1:An invalid parameter has been correctly detected.'' //)') else if ( kprint == 3 ) then write (LUN, '('' CDRIV1:An invalid parameter has been correctly detected.'')') write (LUN, *) ' The value of N was set to ', NX write (LUN, *) & ' MSTATE = ', MSTATE, ', Error number = ', IERFLG write (LUN, '(/)') end if else if ( kprint == 1 ) then write (LUN, '('' CDRIV1:An invalid parameter has not been correctly detected.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' CDRIV1:An invalid parameter has not been correctly detected.'')') write (LUN, *) ' The value of N was set to ', NX write (LUN, *) & ' MSTATE = ', MSTATE, ', Error number = ', IERFLG write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) ' EPS ', EPS, ', LENW ', LENW write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(/)') end if ipass = 0 end if ! Exercise CDRIV2 for problem ! with known solution. call xerclr T = 0.E0 Y(1) = 10.E0 Y(2) = 0.E0 Y(3) = 10.E0 Y(4) = ALFA MSTATE = 1 TOUT = 10.E0 MINT = 1 LENW = 298 LENIW = 50 call CDRIV2 (N, T, Y, CDF, TOUT, MSTATE, NROOT, EPS, EWT, & MINT, WORK, LENW, IWORK, LENIW, CDF, IERFLG) NSTEP = IWORK(3) NFE = IWORK(4) NJE = IWORK(5) if ( MSTATE == 2 ) then if ( ABS(0.620174E0 - ABS(Y(1))) <= EPS**(2.E0/3.E0) .and. & ABS(0.392232E0 - ABS(Y(2))) <= EPS**(2.E0/3.E0) .and. & ABS(1.E0 - ABS(Y(3))) <= EPS**(2.E0/3.E0) ) then if ( kprint == 2 ) then write (LUN, '('' CDRIV2:The solution determined met the expected values.'' //)') else if ( kprint == 3 ) then write (LUN, '('' CDRIV2:The solution determined met the expected values.'')') write (LUN, '('' The values of results are '')') write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, '(/)') end if else if ( kprint == 1 ) then write (LUN, '('' CDRIV2:The solution determined is not accurate enough. //'')') else if ( kprint == 2 ) then write (LUN, '('' CDRIV2:The solution determined is not accurate enough.'')') write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) ' EPS = ', EPS, ', EWT = ', EWT write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(/)') end if ipass = 0 end if else if ( kprint == 1 ) then write (LUN, '('' While using CDRIV2, a solution was not obtained.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' While using CDRIV2, a solution was not obtained.'')') write (LUN, *) & ' MSTATE = ', MSTATE, ', Error number = ', IERFLG write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) ' EPS = ', EPS, ', EWT ', EWT write (LUN, *) & ' MINT = ', MINT, ', LENW ', LENW, ', LENIW ', LENIW write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(/)') end if ipass = 0 end if ! Run CDRIV2 with invalid input. call xerclr T = 0.E0 Y(1) = 10.E0 Y(2) = 0.E0 Y(3) = 10.E0 Y(4) = ALFA TOUT = 10.E0 MSTATE = 1 MINT = 1 LENWX = 1 LENIW = 50 call CDRIV2 (N, T, Y, CDF, TOUT, MSTATE, NROOT, EPS, EWT, & MINT, WORK, LENWX, IWORK, LENIW, CDF, IERFLG) if ( IERFLG == 32 ) then if ( kprint == 2 ) then write (LUN, '('' CDRIV2:An invalid parameter has been correctly detected.'' //)') else if ( kprint == 3 ) then write (LUN, '('' CDRIV2:An invalid parameter has been correctly detected.'')') write (LUN, *) & ' The value of LENW was set to ', LENWX write (LUN, *) & ' MSTATE = ', MSTATE, ', Error number = ', IERFLG write (LUN, '(/)') end if else if ( kprint == 1 ) then write (LUN, '('' CDRIV2:An invalid parameter has not been correctly detected.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' CDRIV2:An invalid parameter has not been correctly detected.'')') write (LUN, *) ' The value of LENW was set to ', LENWX write (LUN, *) & ' MSTATE = ', MSTATE, ', Error number = ', IERFLG write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) & ' EPS ', EPS, ', MINT ', MINT, ', LENW ', LENW, & ', LENIW ', LENIW write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(/)') end if ipass = 0 end if ! ! Exercise CDRIV3 for problem with known solution. ! call xerclr T = 0.E0 Y(1) = 10.E0 Y(2) = 0.E0 Y(3) = 10.E0 Y(4) = ALFA NSTATE = 1 TOUT = 10.E0 MINT = 2 LENW = 301 LENIW = 53 call CDRIV3 (N, T, Y, CDF, NSTATE, TOUT, NTASK, NROOT, EPS, EWT, & IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, & WORK, LENW, IWORK, LENIW, CDF, CDF, NDE, & MXSTEP, CDF, CDF, IERFLG) NSTEP = IWORK(3) NFE = IWORK(4) NJE = IWORK(5) if ( NSTATE == 2 ) then if ( ABS(0.620174E0 - ABS(Y(1))) <= EPS**(2.E0/3.E0) .and. & ABS(0.392232E0 - ABS(Y(2))) <= EPS**(2.E0/3.E0) .and. & ABS(1.E0 - ABS(Y(3))) <= EPS**(2.E0/3.E0) ) then if ( kprint == 2 ) then write (LUN, '('' CDRIV3:The solution determined met the expected values.'' //)') else if ( kprint == 3 ) then write (LUN, '('' CDRIV3:The solution determined met the expected values.'')') write (LUN, '('' The values of results are '')') write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, '(/)') end if else if ( kprint == 1 ) then write (LUN, '('' CDRIV3:The solution determined is not accurate enough.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' CDRIV3:The solution determined is not accurate enough.'')') write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) & ' EPS = ', EPS, ', EWT = ', EWT, ', IERROR = ', IERROR write (LUN, *) & ' MINT = ', MINT, ', MITER = ', MITER, ', IMPL = ', IMPL write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(/)') end if ipass = 0 end if else if ( kprint == 1 ) then write (LUN, '('' While using CDRIV3, a solution was not obtained.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' While using CDRIV3, a solution was not obtained.'')') write (LUN, *) & ' MSTATE = ', MSTATE, ', Error number = ', IERFLG write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) & ' EPS = ', EPS, ', EWT = ', EWT, ', IERROR = ', IERROR write (LUN, *) & ' MINT = ', MINT, ', MITER = ', MITER, ', IMPL = ', IMPL write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(/)') end if ipass = 0 end if ! ! Run CDRIV3 with invalid input. ! call xerclr T = 0.E0 Y(1) = 10.E0 Y(2) = 0.E0 Y(3) = 10.E0 Y(4) = ALFA NSTATE = 1 TOUT = 10.E0 MINT = 2 LENW = 301 LENIWX = 1 call CDRIV3 (N, T, Y, CDF, NSTATE, TOUT, NTASK, NROOT, EPS, & EWT, IERROR, MINT, MITER, IMPL, ML, MU, & MXORD, HMAX, WORK, LENW, IWORK, LENIWX, CDF, & CDF, NDE, MXSTEP, CDF, CDF, IERFLG) if ( IERFLG == 33 ) then if ( kprint == 2 ) then write (LUN, '('' CDRIV3:An invalid parameter has been correctly detected.'' //)') else if ( kprint == 3 ) then write (LUN, '('' CDRIV3:An invalid parameter has been correctly detected.'')') write (LUN, *) & ' The value of LENIW was set to ', LENIWX write (LUN, *) & ' NSTATE = ', NSTATE, ', Error number = ', IERFLG write (LUN, '(/)') end if else if ( kprint == 1 ) then write (LUN, '('' CDRIV3:An invalid parameter has not been correctly detected.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' CDRIV3:An invalid parameter has not been correctly detected.'')') write (LUN, *) & ' The value of LENIW was set to ', LENIWX write (LUN, *) & ' NSTATE = ', NSTATE, ', Error number = ', IERFLG write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) & ' EPS = ', EPS, ', EWT = ', EWT, ', IERROR = ', IERROR write (LUN, *) & ' MINT = ', MINT, ', MITER = ', MITER, ', IMPL = ', IMPL write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(/)') end if ipass = 0 end if call xerclr return end !! CDQNG !***PURPOSE Quick check for DQNG. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (CQNG-S, CDQNG-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED d1mach, DF1N, DF2N, DPRIN, DQNG !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) !***END PROLOGUE CDQNG ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CDQNG (LUN, KPRINT, IPASS) double precision A,ABSERR,B,d1mach,EPMACH,EPSABS,EPSREL,EXACT1, & ERROR,EXACT2,DF1N,DF2N,RESULT,UFLOW integer IER,IERV,IP,IPASS,KPRINT,NEVAL dimension IERV(1) EXTERNAL DF1N,DF2N DATA EXACT1/0.7281029132255818D+00/ !***FIRST EXECUTABLE STATEMENT CDQNG DATA EXACT2/0.1D+02/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1DQNG QUICK CHECK''/)') ipass = 1 EPSABS = 0.0D+00 EPMACH = d1mach(4) UFLOW = d1mach(1) EPSREL = max ( SQRT(EPMACH),0.1D-07) A=0.0D+00 B=0.1D+01 call DQNG(DF1N,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER) call DQNG(DF1N,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER) IERV(1)=IER IP = 0 ERROR = ABS(EXACT1-RESULT) if ( IER == 0 .and. ERROR <= ABSERR.AND.ABSERR <= EPSREL*ABS(EXACT1)) & IP = 1 if ( IP == 0) ipass = 0 if ( kprint /= 0) call DPRIN(LUN,0,KPRINT,IP,EXACT1,RESULT,ABSERR, & ! ! TEST ON IER = 1 ! NEVAL,IERV,1) call DQNG(DF2N,A,B,UFLOW,0.0D+00,RESULT,ABSERR,NEVAL,IER) IERV(1) = IER IP=0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 if ( kprint /= 0) call DPRIN(LUN,1,KPRINT,IP,EXACT2,RESULT,ABSERR, & ! ! TEST ON IER = 6 ! NEVAL,IERV,1) EPSABS = 0.0D+00 EPSREL = 0.0D+00 call DQNG(DF1N,A,B,EPSABS,0.0D+00,RESULT,ABSERR,NEVAL,IER) IERV(1) = IER IP = 0 if ( IER == 6 .and. RESULT == 0.0D+00.AND.ABSERR == 0.0D+00.AND. & NEVAL == 0) IP = 1 if ( IP == 0) ipass = 0 if ( kprint /= 0) call DPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR, & ! NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CDQNG FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CDQNG PASSED''/)') end if end if return end !! CFNCK !***PURPOSE Quick check for the complex Fullerton special functions. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Boland, W. Robert, (LANL) ! Chow, Jeff, (LANL) ! Rivera, Shawn, (LANL) !***DESCRIPTION ! ! This subroutine does a quick check for the complex ! routines in the Fullerton special function library. ! ! Parameter list- ! ! LUN input integer value to designate the external ! device unit for message output ! kprint input integer value to specify amount of ! printing to be done by quick check ! ipass output value indicating whether tests passed or ! failed ! !***ROUTINES CALLED C0LGMC, CACOS, CACOSH, CASIN, CASINH, CATAN, ! CATAN2, CATANH, CBETA, CCBRT, CCOSH, CCOT, CEXPRL, ! CGAMMA, CGAMR, CLBETA, CLNGAM, CLNREL, CLOG10, ! CPSI, CSINH, CTAN, CTANH, R1MACH !***REVISION HISTORY (YYMMDD) ! 800901 DATE WRITTEN ! 891115 REVISION DATE from Version 3.2 ! 891120 Checks of remainder of FNLIB routines added and code ! reorganized. (WRB) ! 900330 Prologue converted to Version 4.0 format. (BAB) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE CFNCK subroutine CFNCK (LUN, KPRINT, IPASS) integer I, lun, kprint, ipass REAL SQRT2,SQRT3,PI,R1MACH, & ERRMAX,ERRTOL,ABSERR,RELERR COMPLEX C(48),W(48),C1,CI, & C0LGMC,CACOS,CACOSH,CASIN,CASINH,CATAN,CATAN2,CATANH, & CBETA,CCBRT,CCOSH,CCOT,CEXPRL,CGAMMA,CGAMR,CLBETA,CLNGAM, & CLNREL,CLOG10,CPSI,CSINH,CTAN,CTANH ! ! Constants to be used ! EXTERNAL CCOT, CGAMMA DATA C1 /(1.E0,0.E0)/,CI /(0.E0,1.E0)/ DATA SQRT2 /.14142135623730950488E1/ DATA SQRT3 /.17320508075688772935E1/ ! ! Complex values through different calculations are stored in C(*) ! DATA PI /3.14159265358979323846E0/ DATA C( 1) /( .121699028117870E+1, .326091563038355E+0)/ DATA C( 2) /( .866025403784438E+0, .500000000000000E+0)/ DATA C( 3) /( .520802437952465E+0,-.196048071390002E+1)/ DATA C( 4) /( .599865470357589E+0, .113287925945897E+1)/ DATA C( 5) /( .970930856437313E+0,-.113287925945897E+1)/ DATA C( 6) /( .104999388884240E+1, .196048071389998E+1)/ DATA C( 7) /( .313314753080534E-1, .541264220944095E-1)/ DATA C( 8) /(-.785398163397449E+0, .658478948462413E+0)/ DATA C( 9) /(-.785398163397449E+0,-.658478948462413E+0)/ DATA C(10) /( .785398163397449E+0,-.658478948462413E+0)/ DATA C(11) /( .313314753080534E-1, .541264220944095E-1)/ DATA C(12) /(-.313314753080534E-1, .541264220944095E-1)/ DATA C(13) /( .183048772171245E+1, .000000000000000E+0)/ DATA C(14) /(-.757236713834364E-1,-.961745759068982E+0)/ DATA C(15) /(-.813630257280238E-1, .103336966511721E+1)/ DATA C(16) /( .546302489843789E+0, .000000000000000E+0)/ DATA C(17) /( .150514997831990E+0,-.341094088460459E+0)/ DATA C(18) /( .301029995663980E+0, .227396058973639E+0)/ DATA C(19) /( .000000000000000E+0, .636619772367581E+0)/ DATA C(20) /( .137802461354738E+1, .909330673631480E+0)/ DATA C(21) /( .303123109082158E-1,-.244978663126864E+0)/ DATA C(22) /( .693147180559947E+0, .523598775598298E+0)/ DATA C(23) /(-.152857091948100E+1, .114371774040242E+1)/ DATA C(24) /( .144363547517882E+1, .157079632679490E+1)/ DATA C(25) /(-.100000000000000E+1, .000000000000000E+0)/ DATA C(26) /( .181878614736412E+1, .586225017697977E+0)/ DATA C(27) /( .402359478108525E+0, .101722196789785E+1)/ DATA C(28) /( .549306144334055E+0,-.157079632679490E+1)/ DATA C(29) /( .000000000000000E+0,-.117520119364380E+1)/ DATA C(30) /(-.642148124715515E+0,-.106860742138277E+1)/ DATA C(31) /( .397515306849130E+0, .104467701612914E+1)/ DATA C(32) /(-.117520119364380E+1, .000000000000000E+0)/ DATA C(33) /(-.116673625724091E+1,-.243458201185722E+0)/ DATA C(34) /( .761594155955766E+0, .000000000000000E+0)/ DATA C(35) /( .365427607174532E-1,-.612881308922810E-1)/ DATA C(36) /( .896860330225849E-2, .244804656578857E-1)/ DATA C(37) /( .177245385090552E+1, .000000000000000E+0)/ DATA C(38) /( .300694617260656E+0,-.424967879433124E+0)/ DATA C(39) /( .110951302025214E+1,-.156806064476794E+1)/ DATA C(40) /( .183074439659052E+1, .569607641036682E+0)/ DATA C(41) /(-.340863758923258E+1, .142127515954291E+1)/ DATA C(42) /(-.156059525546301E+1, .152533527872833E+1)/ DATA C(43) /(-.211272372936533E+0,-.765528316537801E+0)/ DATA C(44) /( .380273164249058E-1,-.286343074460341E+0)/ DATA C(45) /(-.268079774264798E+1, .130151697855085E+1)/ DATA C(46) /(-.164841998888369E+1, .785398163397448E+0)/ DATA C(47) /(-.196351002602143E+1, .000000000000000E+0)/ !***FIRST EXECUTABLE STATEMENT CFNCK ! ! Compute functional values ! ! Exercise routines in Category C2. ! DATA C(48) /( .161278484461574E+1, .147079632679497E+1)/ W( 1) = CCBRT(SQRT2*(1.E0+CI)) ! ! Exercise routines in Category C4A. ! W( 2) = CCBRT(CI) W( 3) = CACOS(PI+SQRT3*CI) W( 4) = CACOS(SQRT2-.25E0*PI*CI) W( 5) = CASIN(SQRT2-.25E0*PI*CI) W( 6) = CASIN(PI+SQRT3*CI) W( 7) = CATAN(.3125E-1+.541265877365273E-1*CI) W( 8) = CATAN(-.5E0+.866025403784438E0*CI) W( 9) = CATAN2(-.5E0-.866025403784438E0*CI,C1) W(10) = CATAN2(.5E0-.866025403784438E0*CI,C1) W(11) = CATAN2(.3125E-1+.541265877365273E-1*CI,C1) W(12) = CATAN2(-.3125E-1+.541265877365273E-1*CI,C1) W(13) = CCOT(.5E0+0.E0*CI) W(14) = CCOT(-1.E0+.5E0*PI*CI) W(15) = CTAN(-1.E0+.5E0*PI*CI) ! ! Exercise routines in Category C4B. ! W(16) = CTAN(.5E0+0.E0*CI) W(17) = CLOG10(1.E0-CI) W(18) = CLOG10(SQRT3+CI) W(19) = CEXPRL(PI*CI) W(20) = CEXPRL(1.E0+CI) W(21) = CLNREL(-.25E0*CI) ! ! Exercise routines in Category C4C. ! W(22) = CLNREL(SQRT3-1.E0+CI) W(23) = CACOSH(1.E0-2.E0*CI) W(24) = CACOSH(2.E0*CI) W(25) = CASINH(-.117520119364380E1+0.E0*CI) W(26) = CASINH(2.5E0+1.75E0*CI) W(27) = CATANH(1.E0+1.E0*CI) W(28) = CATANH(2.E0+0.E0*CI) W(29) = CCOSH(1.E0-.5E0*PI*CI) W(30) = CCOSH(-1.E0+2.E0*CI) W(31) = CSINH(1.E0-1.E0/PI+CI) W(32) = CSINH(1.E0+PI*CI) W(33) = CTANH(-1.E0+2.E0*CI) ! ! Exercise routines in Category C7A. ! W(34) = CTANH(1.E0+PI*CI) W(35) = C0LGMC(.5E0+.5E0*CI) W(36) = C0LGMC(1.E0-1.E0*CI) W(37) = CGAMMA(.5E0+0.E0*CI) W(38) = CGAMMA(.5E0+CI) W(39) = CGAMR(.5E0-CI) W(40) = CGAMR(1.E0+CI) W(41) = CLNGAM(1.1E0+3.2E0*CI) ! ! Exercise routines in Category C7B. ! W(42) = CLNGAM(1.9E0+2.4E0*CI) W(43) = CBETA(1.E0+CI,1.E0+CI) W(44) = CBETA(2.E0-CI,.5E0+CI) W(45) = CLBETA(2.E0+CI,1.E0-2.E0*CI) ! ! Exercise routines in Category C7C. ! W(46) = CLBETA(1.E0-CI,2.E0+CI) W(47) = CPSI(.5E0+0.E0*CI) ! ! Check for possible errors ! W(48) = CPSI(1.E0+5.E0*CI) ERRMAX = R1MACH(4) ERRTOL = SQRT(ERRMAX) DO I = 1,48 ABSERR = ABS(C(I)-W(I)) RELERR = ABSERR/ABS(C(I)) ERRMAX = max ( RELERR,ERRMAX) if ( RELERR > ERRTOL .and. KPRINT >= 2) & write (LUN,620) I,RELERR,ABSERR end do ipass = 0 if ( ERRMAX <= ERRTOL) ipass = 1 if ( ipass /= 0 .and. KPRINT >= 2) write (LUN,610) return 610 FORMAT (' Complex Fullerton special function routines o.k.') 620 FORMAT (' For I = ', I3, ' test fails with RELERR = ', & E38.30, ' and ABSERR = ', E38.30) end !! CGBQC !***PURPOSE Quick check for CGBFA, CGBCO, CGBSL and CGBDI. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS ! OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. ! THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C ! (THE SOLUTION VECTOR), DC (DETERMINANT OF A ), AND ! RCND (RCOND) ARE ENTERED WITH DATA STATEMENTS. ! ! THE COMPUTED TEST RESULTS FOR X, RCOND AND THE DETER- ! MINANT ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. ! FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT ! DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH ! LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS ! PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. ! ! NO INPUT ARGUMENTS ARE REQUIRED. ! ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF ! ALL FAILURES DETECTED BY CGBQC. ! !***ROUTINES CALLED CGBCO, CGBDI, CGBFA, CGBSL !***REVISION HISTORY (YYMMDD) ! 801015 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if, moved an ARITHMETIC ! STATEMENT FUNCTION ahead of the FIRST EXECUTABLE STATEMENT ! record and cleaned up FORMATs. (RWC) !***END PROLOGUE CGBQC subroutine CGBQC (LUN, KPRINT, NERR) COMPLEX ABD(6,4),AT(7,4),B(4),BT(4),C(4),DET(2),DC(2), & Z(4),XA,XB REAL R,RCOND,RCND,DELX CHARACTER KFAIL*39,KPROG*19 integer LDA,N,IPVT(4),INFO,I,J,INDX,NERR integer ML,MU DATA ABD/(0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (3.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0),(0.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA DC/(3.3E0,0.E0),(1.0E0,0.E0)/ DATA KPROG/'GBFA GBCO GBSL GBDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE'/ ! DATA RCND/.24099E0/ !***FIRST EXECUTABLE STATEMENT CGBQC DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) LDA = 7 N = 4 ML = 1 MU = 3 ! ! FORM AT FOR CGBFA AND BT FOR CGBSL, TEST CGBFA ! NERR = 0 DO J=1,N BT(J) = B(J) AT(1:6,J) = ABD(1:6,J) end do call CGBFA(AT,LDA,N,ML,MU,IPVT,INFO) if ( INFO /= 0 ) then write (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ! ! TEST CGBSL FOR JOB=0 ! end if call CGBSL(AT,LDA,N,ML,MU,IPVT,BT,0) INDX = 0 DO 40 I=1,N if ( DELX(C(I),BT(I)) > .0001) INDX=INDX+1 40 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ! ! FORM AT FOR CGBCO AND BT FOR CGBSL, TEST CGBCO ! end if DO 70 J=1,N BT(J) = B(J) DO 60 I=1,6 AT(I,J) = ABD(I,J) 60 continue ! 70 continue call CGBCO(AT,LDA,N,ML,MU,IPVT,RCOND,Z) R = ABS(RCND-RCOND) if ( R >= .0001 ) then write (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ! ! TEST CGBSL FOR JOB NOT EQUAL TO 0 ! end if call CGBSL(AT,LDA,N,ML,MU,IPVT,BT,1) INDX = 0 DO 90 I=1,N if ( DELX(C(I),BT(I)) > .0001) INDX=INDX+1 ! 90 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ! ! TEST CGBDI ! end if call CGBDI(AT,LDA,N,ML,MU,IPVT,DET) INDX = 0 DO 110 I=1,2 if ( DELX(DC(I),DET(I)) > .0001) INDX=INDX+1 ! 110 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ! end if if ( KPRINT >= 2 .OR. NERR /= 0) write (LUN,200) NERR ! return 200 FORMAT(/' * CGBQC - TEST FOR CGBFA, CGBCO, CGBSL AND CGBDI FOUND ' & , I1, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) end !! CGECK !***PURPOSE Quick check for CGEFA, CGECO, CGESL and CGEDI. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS ! OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. ! THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C ! (THE SOLUTION VECTOR), AINV (INVERSE OF MATRIX A ), DC ! (DETERMINANT OF A ), AND RCND ( RCOND ) ARE ENTERED ! WITH DATA STATEMENTS. ! ! THE COMPUTED TEST RESULTS FOR X, RCOND, THE DETERMINANT, AND ! THE INVERSE ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. ! FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT ! DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH ! LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS ! PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. ! ! NO INPUT ARGUMENTS ARE REQUIRED. ! ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF ! ALL FAILURES DETECTED BY CGECK. ! !***ROUTINES CALLED CGECO, CGEDI, CGEFA, CGESL !***REVISION HISTORY (YYMMDD) ! 801014 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if and cleaned up ! FORMATs. (RWC) !***END PROLOGUE CGECK subroutine CGECK (LUN, KPRINT, NERR) COMPLEX A(4,4),AT(5,4),B(4),BT(4),C(4),AINV(4,4),DET(2),DC(2), & Z(4),XA,XB REAL R,RCOND,RCND,DELX CHARACTER KPROG*19,KFAIL*39 integer LDA,N,IPVT(4),INFO,I,J,INDX,NERR DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA AINV/(.66667E0,0.E0),(0.E0,-.33333E0),(0.E0,0.E0), & (0.E0,0.E0), & (0.E0,.33333E0),(.66667E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(.36364E0,0.E0),(0.E0,-.09091E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,.09091E0),(.27273E0,0.E0)/ DATA DC/(3.3E0,0.E0),(1.0E0,0.E0)/ DATA KPROG/'GEFA GECO GESL GEDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE'/ ! DATA RCND/.24099E0/ !***FIRST EXECUTABLE STATEMENT CGECK DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) LDA = 5 N = 4 ! ! FORM AT FOR CGEFA AND BT FOR CGESL, TEST CGEFA ! NERR = 0 DO 20 J=1,N BT(J) = B(J) AT(1:n,J) = A(1:n,J) 20 continue call CGEFA(AT,LDA,N,IPVT,INFO) if ( INFO /= 0 ) then write (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ! ! TEST CGESL FOR JOB=0 ! end if call CGESL(AT,LDA,N,IPVT,BT,0) INDX = 0 DO 40 I=1,N if ( DELX(C(I),BT(I)) > .0001) INDX=INDX+1 40 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 end if ! ! FORM AT FOR CGECO AND BT FOR CGESL, TEST CGECO ! DO 70 J=1,N BT(J) = B(J) DO 60 I=1,N AT(I,J) = A(I,J) 60 continue 70 continue call CGECO(AT,LDA,N,IPVT,RCOND,Z) R = ABS(RCND-RCOND) if ( R >= .0001 ) then write (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ! ! TEST CGESL FOR JOB NOT EQUAL TO 0 ! end if call CGESL(AT,LDA,N,IPVT,BT,1) INDX = 0 DO I=1,N if ( DELX(C(I),BT(I)) > .0001) INDX=INDX+1 end do if ( INDX /= 0 ) then write (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 end if ! ! TEST CGEDI FOR JOB=11 ! call CGEDI(AT,LDA,N,IPVT,DET,Z,11) INDX = 0 DO I=1,2 if ( DELX(DC(I),DET(I)) > .0001) INDX=INDX+1 end do if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 end if INDX = 0 DO 140 I=1,N DO 130 J=1,N if ( DELX(AINV(I,J),AT(I,J)) > .0001) INDX=INDX+1 130 continue 140 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(33:39) NERR = NERR + 1 end if if ( KPRINT >= 2 .OR. NERR /= 0) write (LUN,200) NERR return 200 FORMAT(/' * CGECK - TEST FOR CGEFA, CGECO, CGESL AND CGEDI FOUND ' & , I1, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) end !! CGEQC !***PURPOSE Quick check for CGEFS and CGEIR. !***LIBRARY SLATEC !***TYPE COMPLEX (SGEQC-S, DGEQC-D, CGEQC-C) !***KEYWORDS QUICK CHECK !***AUTHOR Jacobsen, Nancy, (LANL) !***DESCRIPTION ! ! Let A*X=B be a COMPLEX linear system where the ! matrix is of the proper type for the Linpack subroutines ! being called. The values of A and B and the pre-computed ! values of BXEX (the solution vector) are given in DATA ! statements. The computed test results for X are compared to ! the stored pre-computed values. Failure of the test occurs ! when there is less than 80% agreement between the absolute ! values. There are 2 tests - one for the normal case and one ! for the singular case. A message is printed indicating ! whether each subroutine has passed or failed for each case. ! ! On return, NERR (INTEGER type) contains the total count of ! all failures detected. ! !***ROUTINES CALLED CGEFS, CGEIR !***REVISION HISTORY (YYMMDD) ! 801029 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920601 Code reworked and TYPE section added. (RWC, WRB) !***END PROLOGUE CGEQC ! .. Scalar Arguments .. subroutine CGEQC (LUN, KPRINT, NERR) ! .. Local Scalars .. integer KPRINT, LUN, NERR COMPLEX XA, XB ! .. Local Arrays .. integer I, IND, INDX, ITASK, J, KPROG, LDA, N COMPLEX A(3,3), ATEMP(5,3), B(3), BTEMP(3), BXEX(3), WORK(12) integer IWORK(3) ! .. External Subroutines .. CHARACTER LIST(2)*4 ! .. Intrinsic Functions .. EXTERNAL CGEFS, CGEIR ! .. Statement Functions .. INTRINSIC ABS, AIMAG, REAL ! .. Data statements .. REAL DELX DATA A /(2., 3.), (1., 1.), (1., 2.), & (2., 0.), (1., -1.), (0., 0.), & (0., 0.), (2., 5.), (3., 2.)/ DATA B /(-1., 1.), (-5., 4.), (-4., 7.)/ DATA BXEX /(.21459E-01, .209012E+01), (.261373E+01, -.162231E+01), & (.785407E+00, .109871E+01)/ ! .. Statement Function definitions .. DATA LIST /'GEFS', 'GEIR'/ !***FIRST EXECUTABLE STATEMENT CGEQC DELX(XA,XB) = ABS(REAL(XA-XB)) + ABS(AIMAG(XA-XB)) N = 3 LDA = 5 NERR = 0 ! if ( kprint >= 2) write (LUN,9000) ! ! First test case - normal ! DO 180 KPROG=1,2 ITASK = 1 BTEMP(1:n) = B(1:n) DO 120 J=1,N DO 110 I=1,N ATEMP(I,J) = A(I,J) 110 continue 120 continue if ( KPROG == 1 ) then call CGEFS (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) else call CGEIR (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) end if if ( IND < 0 ) then if ( kprint >= 2) write (LUN, FMT=9020) LIST(KPROG), IND NERR = NERR + 1 ! ! Calculate error for first test ! end if INDX = 0 DO 130 I=1,N if ( DELX(BXEX(I),BTEMP(I)) > .0001) INDX = INDX + 1 130 continue if ( INDX == 0 ) then if ( kprint >= 3) write (LUN, FMT=9010) LIST(KPROG) else if ( kprint >= 2) write (LUN, FMT=9020) LIST(KPROG) NERR = NERR + 1 ! ! Second test case - singular matrix ! end if ITASK = 1 DO 140 I=1,N BTEMP(I) = B(I) 140 continue DO 160 J=1,N DO 150 I=1,N ATEMP(I,J) = A(I,J) 150 continue 160 continue DO 170 J=1,N ATEMP(1,J) = (0.E0,0.E0) 170 continue if ( KPROG == 1 ) then call CGEFS (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) else call CGEIR (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) end if if ( IND == -4 ) then if ( kprint >= 3) write (LUN, FMT=9030) LIST(KPROG) else if ( kprint >= 2) write (LUN, FMT=9040) LIST(KPROG), IND NERR = NERR + 1 end if ! 180 continue if ( KPRINT >= 3 .and. NERR == 0) write (LUN,9050) if ( KPRINT >= 2 .and. NERR /= 0) write (LUN,9060) ! return 9000 FORMAT (//, 2X, 'CGEFS and CGEIR Quick Check' /) 9010 FORMAT (/, 5X, 'C', A, ' Normal test PASSED') 9020 FORMAT (/, 5X, 'C', A, ' Test FAILED') 9030 FORMAT (/, 5X, 'C', A, ' Singular test PASSED') 9040 FORMAT (/, 5X, 'C', A, ' Singular test FAILED, IND=', I3) 9050 FORMAT (/, 2X, 'CGEFS and CGEIR Quick Check PASSED' /) 9060 FORMAT (/, 2X, 'CGEFS and CGEIR Quick Check FAILED' /) end !! CGTQC !***PURPOSE Quick check for CGTSL. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS ! OF THE PROPER TYPE FOR THE LINPACK SUBROUTINE BEING TESTED. ! THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF CX ! (THE SOLUTION VECTOR) ARE ENTERED WITH DATA STATEMENTS. ! ! THE COMPUTED VALUES OF X ARE COMPARED TO THE STORED ! PRE-COMPUTED VALUES OF CX. FAILURE OF THE TEST OCCURS WHEN ! AGREEMENT TO 3 SIGNIFICANT DIGITS IS NOT ACHIEVED AND AN ! ERROR MESSAGE IS PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. ! ! NO INPUT ARGUMENTS ARE REQUIRED. ! ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT ! OF ALL FAILURES DETECTED BY CGTQC. ! !***ROUTINES CALLED CGTSL !***REVISION HISTORY (YYMMDD) ! 801024 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if, moved an ARITHMETIC ! STATEMENT FUNCTION ahead of the FIRST EXECUTABLE STATEMENT ! record and cleaned up FORMATs. (RWC) !***END PROLOGUE CGTQC subroutine CGTQC (LUN, KPRINT, NERR) COMPLEX C(4),D(4),E(4),B(4),CX(4),CT(4),DT(4),ET(4),BT(4) CHARACTER KFAIL*13 integer N,INFO,I,INDX,NERR REAL DELX DATA C/(0.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,1.E0)/ DATA D/(2.E0,0.E0),(2.E0,0.E0),(3.E0,0.E0),(4.E0,0.E0)/ DATA E/(0.E0,-1.E0),(0.E0,0.E0),(0.E0,-1.E0),(0.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA CX/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ !***FIRST EXECUTABLE STATEMENT CGTQC DATA KFAIL/'INFO SOLUTION'/ N = 4 NERR = 0 CT(1:n) = C(1:n) DT(1:n) = D(1:n) ET(1:n) = E(1:n) BT(1:n) = B(1:n) call CGTSL(N,CT,DT,ET,BT,INFO) if ( INFO /= 0 ) then write (LUN,201) KFAIL(1:4) NERR = NERR + 1 end if INDX = 0 DO 30 I=1,N DELX = ABS(REAL(BT(I)-CX(I)))+ABS(AIMAG(BT(I)-CX(I))) if ( DELX > .0001) INDX=INDX+1 ! 30 continue if ( INDX /= 0 ) then write (LUN,201) KFAIL(6:13) NERR = NERR + 1 ! end if if ( KPRINT >= 2 .OR. NERR /= 0) write (LUN,200) NERR ! return 200 FORMAT (/' * CGTQC - TEST FOR CGTSL FOUND ', I1, ' ERRORS.'/) 201 FORMAT (/' *** CGTSL FAILURE - ERROR IN ', A) end !! CHECK0 !***PURPOSE (UNKNOWN) !***LIBRARY SLATEC !***AUTHOR Lawson, C. L., (JPL) ! Hanson, R. J., (SNLA) ! Wisniewski, J. A., (SNLA) !***DESCRIPTION ! ! THIS SUBROUTINE TESTS SUBPROGRAMS 12-13 AND 16-17. ! THESE SUBPROGRAMS HAVE NO ARRAY ARGUMENTS. ! ! C. L. LAWSON, JPL, 1975 MAR 07, MAY 28 ! R. J. HANSON, J. A. WISNIEWSKI, SANDIA LABS, APRIL 25,1977. ! !***ROUTINES CALLED DROTG, DROTMG, DTEST, SROTG, SROTMG, STEST !***COMMON BLOCKS COMBLA !***REVISION HISTORY (YYMMDD) ! 750307 DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CHECK0 subroutine CHECK0 (SFAC, DFAC, KPRINT) COMMON /COMBLA/ NPRINT, ICASE, N, INCX, INCY, MODE, PASS LOGICAL PASS REAL STRUE(9),STEMP(9) double precision DC,DS,DA1(8),DB1(8),DC1(8),DS1(8) double precision DA,DATRUE(8),DBTRUE(8),DZERO,DFAC,DB double precision DAB(4,9),DTEMP(9),DTRUE(9,9),D12 DATA ZERO, DZERO / 0., 0.D0 / DATA DA1/ .3D0, .4D0, -.3D0, -.4D0, -.3D0, 0.D0, 0.D0, 1.D0/ DATA DB1/ .4D0, .3D0, .4D0, .3D0, -.4D0, 0.D0, 1.D0, 0.D0/ DATA DC1/ .6D0, .8D0, -.6D0, .8D0, .6D0, 1.D0, 0.D0, 1.D0/ DATA DS1/ .8D0, .6D0, .8D0, -.6D0, .8D0, 0.D0, 1.D0, 0.D0/ DATA DATRUE/ .5D0, .5D0, .5D0, -.5D0, -.5D0, 0.D0, 1.D0, 1.D0/ ! INPUT FOR MODIFIED GIVENS DATA DBTRUE/ 0.D0, .6D0, 0.D0, -.6D0, 0.D0, 0.D0, 1.D0, 0.D0/ DATA DAB/ .1D0,.3D0,1.2D0,.2D0, & .7D0, .2D0, .6D0, 4.2D0, & 0.D0,0.D0,0.D0,0.D0, & 4.D0, -1.D0, 2.D0, 4.D0, & 6.D-10, 2.D-2, 1.D5, 10.D0, & 4.D10, 2.D-2, 1.D-5, 10.D0, & 2.D-10, 4.D-2, 1.D5, 10.D0, & 2.D10, 4.D-2, 1.D-5, 10.D0, & ! TRUE RESULTS FOR MODIFIED GIVENS 4.D0, -2.D0, 8.D0, 4.D0 / DATA DTRUE/0.D0,0.D0, 1.3D0, .2D0, 0.D0,0.D0,0.D0, .5D0, 0.D0, & 0.D0,0.D0, 4.5D0, 4.2D0, 1.D0, .5D0, 0.D0,0.D0,0.D0, & 0.D0,0.D0,0.D0,0.D0, -2.D0, 0.D0,0.D0,0.D0,0.D0, & 0.D0,0.D0,0.D0, 4.D0, -1.D0, 0.D0,0.D0,0.D0,0.D0, & 0.D0, 15.D-3, 0.D0, 10.D0, -1.D0, 0.D0, -1.D-4, & 0.D0, 1.D0, & 0.D0,0.D0, 6144.D-5, 10.D0, -1.D0, 4096.D0, -1.D6, & 0.D0, 1.D0, & 0.D0,0.D0,15.D0,10.D0,-1.D0, 5.D-5, 0.D0,1.D0,0.D0, & 0.D0,0.D0, 15.D0, 10.D0, -1.0D0, 5.D5, -4096.D0, & 1.D0, 4096.D-6, & ! 4096 = 2 ** 12 0.D0,0.D0, 7.D0, 4.D0, 0.D0,0.D0, -.5D0, -.25D0, 0.D0/ !***FIRST EXECUTABLE STATEMENT CHECK0 ! ! COMPUTE TRUE VALUES WHICH CANNOT BE PRESTORED ! IN DECIMAL NOTATION. DATA D12 /4096.D0/ DTRUE(1,1) = 12.D0 / 130.D0 DTRUE(2,1) = 36.D0 / 130.D0 DTRUE(7,1) = -1.D0 / 6.D0 DTRUE(1,2) = 14.D0 / 75.D0 DTRUE(2,2) = 49.D0 / 75.D0 DTRUE(9,2) = 1.D0 / 7.D0 DTRUE(1,5) = 45.D-11 * (D12 * D12) DTRUE(3,5) = 4.D5 / (3.D0 * D12) DTRUE(6,5) = 1.D0 / D12 DTRUE(8,5) = 1.D4 / (3.D0 * D12) DTRUE(1,6) = 4.D10 / (1.5D0 * D12 * D12) DTRUE(2,6) = 2.D-2 / 1.5D0 DTRUE(8,6) = 5.D-7 * D12 DTRUE(1,7) = 4.D0 / 150.D0 DTRUE(2,7) = (2.D-10 / 1.5D0) * (D12 * D12) DTRUE(7,7) = -DTRUE(6,5) DTRUE(9,7) = 1.D4 / D12 DTRUE(1,8) = DTRUE(1,7) DTRUE(2,8) = 2.D10 / (1.5D0 * D12 * D12) DTRUE(1,9) = 32.D0 / 7.D0 DTRUE(2,9) = -16.D0 / 7.D0 DBTRUE(1) = 1.D0/.6D0 DBTRUE(3) = -1.D0/.6D0 ! DBTRUE(5) = 1.D0/.6D0 JUMP= ICASE-11 ! SET N=K FOR IDENTIFICATION IN OUTPUT IF ANY. DO 500 K = 1, 9 ! BRANCH TO SELECT SUBPROGRAM TO BE TESTED. ! N=K ! 12. SROTG GO TO (120,130,999,999,160,170), JUMP 120 if ( K > 8) GO TO 600 SA = DA1(K) SB = DB1(K) call SROTG(SA,SB,SC,SS) call STEST(1,SA,REAL(DATRUE(K)),REAL(DATRUE(K)),SFAC,KPRINT) call STEST(1,SB,REAL(DBTRUE(K)),REAL(DBTRUE(K)),SFAC,KPRINT) call STEST(1,SC,REAL(DC1(K)),REAL(DC1(K)),SFAC,KPRINT) call STEST(1,SS,REAL(DS1(K)),REAL(DS1(K)),SFAC,KPRINT) ! 13. DROTG GO TO 500 130 if ( K > 8) GO TO 600 DA = DA1(K) DB = DB1(K) call DROTG(DA,DB,DC,DS) call DTEST(1,DA,DATRUE(K),DATRUE(K),DFAC,KPRINT) call DTEST(1,DB,DBTRUE(K),DBTRUE(K),DFAC,KPRINT) call DTEST(1,DC,DC1(K),DC1(K),DFAC,KPRINT) call DTEST(1,DS,DS1(K),DS1(K),DFAC,KPRINT) ! 16. SROTMG GO TO 500 160 continue DO 162 I = 1, 4 STEMP(I) = DAB(I,K) STEMP(I+4) = ZERO 162 continue STEMP(9) = ZERO ! call SROTMG(STEMP(1),STEMP(2),STEMP(3),STEMP(4),STEMP(5)) DO 166 I = 1, 9 166 STRUE(I) = DTRUE(I,K) call STEST(9,STEMP,STRUE,STRUE,SFAC,KPRINT) ! 17. DROTMG GO TO 500 170 continue DO 172 I = 1, 4 DTEMP(I) = DAB(I,K) DTEMP(I+4) = DZERO 172 continue DTEMP(9) = DZERO call DROTMG(DTEMP(1),DTEMP(2),DTEMP(3),DTEMP(4),DTEMP(5)) call DTEST(9,DTEMP,DTRUE(1,K),DTRUE(1,K),DFAC,KPRINT) 500 continue ! THE FOLLOWING STOP SHOULD NEVER BE REACHED. 600 RETURN 999 STOP end !! CHECK1 !***PURPOSE (UNKNOWN) !***LIBRARY SLATEC !***AUTHOR Lawson, C. L., (JPL) !***DESCRIPTION ! ! THIS SUBPROGRAM TESTS THE INCREMENTING AND ACCURACY OF THE LINEAR ! ALGEBRA SUBPROGRAMS 26 - 38 (SNRM2 TO ICAMAX). STORED RESULTS ARE ! COMPARED WITH THE RESULT RETURNED BY THE SUBPROGRAM. ! ! THESE SUBPROGRAMS REQUIRE A SINGLE VECTOR ARGUMENT. ! ! ICASE DESIGNATES WHICH SUBPROGRAM TO TEST. ! 26 <= ICASE <= 38 ! C. L. LAWSON, JPL, 1974 DEC 10, MAY 28 ! !***ROUTINES CALLED CSCAL, CSSCAL, DASUM, DNRM2, DSCAL, DTEST, ICAMAX, ! IDAMAX, ISAMAX, ITEST, SASUM, SCASUM, SCNRM2, ! SNRM2, SSCAL, STEST !***COMMON BLOCKS COMBLA !***REVISION HISTORY (YYMMDD) ! 741210 DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CHECK1 subroutine CHECK1 (SFAC, DFAC, KPRINT) COMMON /COMBLA/ NPRINT, ICASE, N, INCX, INCY, MODE, PASS LOGICAL PASS integer ITRUE2(5),ITRUE3(5) double precision DA,DX(8) double precision DV(8,5,2) double precision DFAC double precision DNRM2,DASUM double precision DTRUE1(5),DTRUE3(5),DTRUE5(8,5,2) REAL STRUE2(5),STRUE4(5),STRUE(8),SX(8) ! COMPLEX CA,CV(8,5,2),CTRUE5(8,5,2),CTRUE6(8,5,2),CX(8) DATA SA, DA, CA / .3, .3D0, (.4,-.7) / DATA DV/.1D0,2.D0,2.D0,2.D0,2.D0,2.D0,2.D0,2.D0, & .3D0,3.D0,3.D0,3.D0,3.D0,3.D0,3.D0,3.D0, & .3D0,-.4D0,4.D0,4.D0,4.D0,4.D0,4.D0,4.D0, & .2D0,-.6D0,.3D0,5.D0,5.D0,5.D0,5.D0,5.D0, & .1D0,-.3D0,.5D0,-.1D0,6.D0,6.D0,6.D0,6.D0, & .1D0,8.D0,8.D0,8.D0,8.D0,8.D0,8.D0,8.D0, & .3D0,9.D0,9.D0,9.D0,9.D0,9.D0,9.D0,9.D0, & .3D0,2.D0,-.4D0,2.D0,2.D0,2.D0,2.D0,2.D0, & .2D0,3.D0,-.6D0,5.D0,.3D0,2.D0,2.D0,2.D0, & ! COMPLEX TEST VECTORS .1D0,4.D0,-.3D0,6.D0,-.5D0,7.D0,-.1D0, 3.D0/ DATA CV/ & (.1,.1),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.), & (.3,-.4),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.), & (.1,-.3),(.5,-.1),(5.,6.),(5.,6.),(5.,6.),(5.,6.),(5.,6.),(5.,6.), & (.1,.1),(-.6,.1),(.1,-.3),(7.,8.),(7.,8.),(7.,8.),(7.,8.),(7.,8.), & (.3,.1),(.1,.4),(.4,.1),(.1,.2),(2.,3.),(2.,3.),(2.,3.),(2.,3.), & (.1,.1),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.), & (.3,-.4),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.), & (.1,-.3),(8.,9.),(.5,-.1),(2.,5.),(2.,5.),(2.,5.),(2.,5.),(2.,5.), & (.1,.1),(3.,6.),(-.6,.1),(4.,7.),(.1,-.3),(7.,2.),(7.,2.),(7.,2.), & ! (.3,.1),(5.,8.),(.1,.4),(6.,9.),(.4,.1),(8.,3.),(.1,.2),(9.,4.) / DATA STRUE2/.0,.5,.6,.7,.7/ DATA STRUE4/.0,.7,1.,1.3,1.7/ DATA DTRUE1/.0D0,.3D0,.5D0,.7D0,.6D0/ DATA DTRUE3/.0D0,.3D0,.7D0,1.1D0,1.D0/ DATA DTRUE5/.10D0,2.D0,2.D0,2.D0,2.D0,2.D0,2.D0,2.D0, & .09D0,3.D0,3.D0,3.D0,3.D0,3.D0,3.D0,3.D0, & .09D0,-.12D0,4.D0,4.D0,4.D0,4.D0,4.D0,4.D0, & .06D0,-.18D0,.09D0,5.D0,5.D0,5.D0,5.D0,5.D0, & .03D0,-.09D0,.15D0,-.03D0,6.D0,6.D0,6.D0,6.D0, & .10D0,8.D0,8.D0,8.D0,8.D0,8.D0,8.D0,8.D0, & .09D0,9.D0,9.D0,9.D0,9.D0,9.D0,9.D0,9.D0, & .09D0,2.D0,-.12D0,2.D0,2.D0,2.D0,2.D0,2.D0, & .06D0,3.D0,-.18D0,5.D0,.09D0,2.D0,2.D0,2.D0, & ! .03D0,4.D0, -.09D0,6.D0, -.15D0,7.D0, -.03D0, 3.D0/ DATA CTRUE5/ & (.1,.1),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.), & (-.16,-.37),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.), & (3.,4.), & (-.17,-.19),(.13,-.39),(5.,6.),(5.,6.),(5.,6.),(5.,6.),(5.,6.), & (5.,6.), & (.11,-.03),(-.17,.46),(-.17,-.19),(7.,8.),(7.,8.),(7.,8.),(7.,8.), & (7.,8.), & (.19,-.17),(.32,.09),(.23,-.24),(.18,.01),(2.,3.),(2.,3.),(2.,3.), & (2.,3.), & (.1,.1),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.), & (-.16,-.37),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.), & (6.,7.), & (-.17,-.19),(8.,9.),(.13,-.39),(2.,5.),(2.,5.),(2.,5.),(2.,5.), & (2.,5.), & (.11,-.03),(3.,6.),(-.17,.46),(4.,7.),(-.17,-.19),(7.,2.),(7.,2.), & (7.,2.), & (.19,-.17),(5.,8.),(.32,.09),(6.,9.),(.23,-.24),(8.,3.),(.18,.01), & ! (9.,4.) / DATA CTRUE6/ & (.1,.1),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.),(1.,2.), & (.09,-.12),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.),(3.,4.), & (3.,4.), & (.03,-.09),(.15,-.03),(5.,6.),(5.,6.),(5.,6.),(5.,6.),(5.,6.), & (5.,6.), & (.03,.03),(-.18,.03),(.03,-.09),(7.,8.),(7.,8.),(7.,8.),(7.,8.), & (7.,8.), & (.09,.03),(.03,.12),(.12,.03),(.03,.06),(2.,3.),(2.,3.),(2.,3.), & (2.,3.), & (.1,.1),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.),(4.,5.), & (.09,-.12),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.),(6.,7.), & (6.,7.), & (.03,-.09),(8.,9.),(.15,-.03),(2.,5.),(2.,5.),(2.,5.),(2.,5.), & (2.,5.), & (.03,.03),(3.,6.),(-.18,.03),(4.,7.),(.03,-.09),(7.,2.),(7.,2.), & (7.,2.), & (.09,.03),(5.,8.),(.03,.12),(6.,9.),(.12,.03),(8.,3.),(.03,.06), & ! ! (9.,4.) / DATA ITRUE2/ 0, 1, 2, 2, 3/ !***FIRST EXECUTABLE STATEMENT CHECK1 DATA ITRUE3/ 0, 1, 2, 2, 2/ JUMP=ICASE-25 DO 520 INCX=1,2 DO 500 NP1=1,5 N=NP1-1 ! SET VECTOR ARGUMENTS. LEN= 2*MAX(N,1) DO 22 I = 1, LEN SX(I) = DV(I,NP1,INCX) DX(I) = DV(I,NP1,INCX) ! ! BRANCH TO INVOKE SUBPROGRAM TO BE TESTED. ! 22 CX(I) = CV(I,NP1,INCX) GO TO (260,270,280,290,300,310,320, & ! 26. SNRM2 330,340,350,360,370,380),JUMP 260 STEMP = DTRUE1(NP1) call STEST(1,SNRM2(N,SX,INCX),STEMP,STEMP,SFAC,KPRINT) ! 27. DNRM2 GO TO 500 270 call DTEST(1,DNRM2(N,DX,INCX),DTRUE1(NP1),DTRUE1(NP1),DFAC, & KPRINT) ! 28. SCNRM2 GO TO 500 280 call STEST(1,SCNRM2(N,CX,INCX),STRUE2(NP1),STRUE2(NP1), & SFAC,KPRINT) ! 29. SASUM GO TO 500 290 STEMP = DTRUE3(NP1) call STEST(1,SASUM(N,SX,INCX),STEMP,STEMP,SFAC,KPRINT) ! 30. DASUM GO TO 500 300 call DTEST(1,DASUM(N,DX,INCX),DTRUE3(NP1),DTRUE3(NP1),DFAC, & KPRINT) ! 31. SCASUM GO TO 500 310 call STEST(1,SCASUM(N,CX,INCX),STRUE4(NP1),STRUE4(NP1),SFAC, & KPRINT) ! 32. SSCALE GO TO 500 320 call SSCAL(N,SA,SX,INCX) DO 322 I = 1, LEN 322 STRUE(I) = DTRUE5(I,NP1,INCX) call STEST(LEN,SX,STRUE,STRUE,SFAC,KPRINT) ! 33. DSCALE GO TO 500 330 call DSCAL(N,DA,DX,INCX) call DTEST(LEN,DX,DTRUE5(1,NP1,INCX),DTRUE5(1,NP1,INCX), & DFAC,KPRINT) ! 34. CSCALE GO TO 500 340 call CSCAL(N,CA,CX,INCX) call STEST(2*LEN,CX,CTRUE5(1,NP1,INCX),CTRUE5(1,NP1,INCX), & SFAC,KPRINT) ! 35. CSSCAL GO TO 500 350 call CSSCAL(N,SA,CX,INCX) call STEST(2*LEN,CX,CTRUE6(1,NP1,INCX),CTRUE6(1,NP1,INCX), & SFAC,KPRINT) ! 36. ISAMAX GO TO 500 360 call ITEST(1,ISAMAX(N,SX,INCX),ITRUE2(NP1),KPRINT) ! 37. IDAMAX GO TO 500 370 call ITEST(1,IDAMAX(N,DX,INCX),ITRUE2(NP1),KPRINT) ! 38. ICAMAX GO TO 500 ! 380 call ITEST(1,ICAMAX(N,CX,INCX),ITRUE3(NP1),KPRINT) 500 continue 520 continue return end !! CHECK2 !***PURPOSE (UNKNOWN) !***LIBRARY SLATEC !***AUTHOR Lawson, C. L., (JPL) !***DESCRIPTION ! ! THIS SUBPROGRAM TESTS THE BASIC LINEAR ALGEBRA SUBPROGRAMS 1-11, ! 14-15, AND 18-25. SUBPROGRAMS IN THIS SET EACH REQUIRE TWO ARRAYS ! IN THE PARAMETER LIST. ! ! C. L. LAWSON, JPL, 1975 FEB 26, APR 29, MAY 8, MAY 28 ! !***ROUTINES CALLED CAXPY, CCOPY, CDOTC, CDOTU, CSWAP, DAXPY, DCOPY, ! DDOT, DQDOTA, DQDOTI, DROT, DROTM, DSDOT, DSWAP, ! DTEST, SAXPY, SCOPY, SDOT, SDSDOT, SROT, SROTM, ! SSWAP, STEST !***COMMON BLOCKS COMBLA !***REVISION HISTORY (YYMMDD) ! 750226 DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CHECK2 subroutine CHECK2 (SFAC, SDFAC, DFAC, DQFAC, KPRINT) ! COMMON /COMBLA/ NPRINT, ICASE, N, INCX, INCY, MODE, PASS LOGICAL PASS integer INCXS(4),INCYS(4),LENS(4,2),NS(4) REAL SX(7),SY(7),STX(7),STY(7),SSIZE1(4),SSIZE2(14,2) REAL SSIZE(7),QC(30),SPARAM(5),ST7B(4,4),SSIZE3(4) double precision DX(7),DA,DX1(7),DY1(7),DY(7),DT7(4,4),DT8(7,4,4) double precision DX2(7), DY2(7), DT2(4,4,2), DPARAM(5), DPAR(5,4) double precision DSDOT,DDOT,DQDOTI,DQDOTA,DFAC,DQFAC double precision DT10X(7,4,4),DT10Y(7,4,4),DB double precision DSIZE1(4),DSIZE2(7,2),DSIZE(7) double precision DC,DS,DT9X(7,4,4),DT9Y(7,4,4),DTX(7),DTY(7) double precision DT19X(7,4,16),DT19XA(7,4,4),DT19XB(7,4,4) double precision DT19XC(7,4,4),DT19XD(7,4,4),DT19Y(7,4,16) double precision DT19YA(7,4,4),DT19YB(7,4,4),DT19YC(7,4,4) ! double precision DT19YD(7,4,4) EQUIVALENCE (DT19X(1,1,1),DT19XA(1,1,1)),(DT19X(1,1,5), & DT19XB(1,1,1)),(DT19X(1,1,9),DT19XC(1,1,1)), & (DT19X(1,1,13),DT19XD(1,1,1)) EQUIVALENCE (DT19Y(1,1,1),DT19YA(1,1,1)),(DT19Y(1,1,5), & DT19YB(1,1,1)),(DT19Y(1,1,9),DT19YC(1,1,1)), & (DT19Y(1,1,13),DT19YD(1,1,1)) COMPLEX CX(7),CA,CX1(7),CY1(7),CY(7),CT6(4,4),CT7(4,4) COMPLEX CT8(7,4,4),CSIZE1(4),CSIZE2(7,2) COMPLEX CT10X(7,4,4), CT10Y(7,4,4) COMPLEX CDOTC,CDOTU DATA SA,DA,CA,DB,SB/.3,.3D0,(.4,-.7),.25D0,.1/ DATA INCXS/ 1, 2, -2, -1 / DATA INCYS/ 1, -2, 1, -2 / DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ DATA NS / 0, 1, 2, 4 / DATA SC,SS,DC,DS/ .8,.6,.8D0,.6D0/ DATA DX1/ .6D0, .1D0,-.5D0, .8D0, .9D0,-.3D0,-.4D0/ DATA DY1/ .5D0,-.9D0, .3D0, .7D0,-.6D0, .2D0, .8D0/ DATA DX2/ 1.D0,.01D0, .02D0,1.D0,.06D0, 2.D0, 1.D0/ ! THE TERMS D11(3,2) AND D11(4,2) WILL BE SET BY ! COMPUTATION AT RUN TIME. DATA DY2/ 1.D0,.04D0,-.03D0,-1.D0,.05D0,3.D0,-1.D0/ DATA CX1/(.7,-.8),(-.4,-.7),(-.1,-.9),(.2,-.8),(-.9,-.4),(.1,.4), & (-.6,.6)/ DATA CY1/(.6,-.6),(-.9,.5),(.7,-.6),(.1,-.5),(-.1,-.2),(-.5,-.3), & ! ! FOR DQDOTI AND DQDOTA ! (.8,-.7) / DATA DT2/0.25D0,1.25D0,1.2504D0,0.2498D0, & 0.25D0,1.25D0,0.24D0,0.2492D0, & 0.25D0,1.25D0,0.31D0,0.2518D0, & 0.25D0,1.25D0,1.2497D0,0.2507D0, & 0.D0,2.D0,2.0008D0,-.0004D0, & 0.D0,2.D0,-.02D0,-.0016D0, & 0.D0,2.D0,.12D0,.0036D0, & 0.D0,2.D0,1.9994D0,.0014D0/ DATA DT7/ 0.D0,.30D0,.21D0,.62D0, 0.D0,.30D0,-.07D0,.85D0, & 0.D0,.30D0,-.79D0,-.74D0, 0.D0,.30D0,.33D0,1.27D0/ DATA ST7B/ .1, .4, .31, .72, .1, .4, .03, .95, & ! ! FOR CDOTU ! .1, .4, -.69, -.64, .1, .4, .43, 1.37/ DATA CT7/(0.,0.),(-.06,-.90),(.65,-.47),(-.34,-1.22), & (0.,0.),(-.06,-.90),(-.59,-1.46),(-1.04,-.04), & (0.,0.),(-.06,-.90),(-.83,.59), ( .07,-.37), & ! ! FOR CDOTC ! (0.,0.),(-.06,-.90),(-.76,-1.15),(-1.33,-1.82)/ DATA CT6/(0.,0.),(.90,0.06), (.91,-.77), (1.80,-.10), & (0.,0.),(.90,0.06), (1.45,.74), (.20,.90), & (0.,0.),(.90,0.06), (-.55,.23), (.83,-.39), & ! (0.,0.),(.90,0.06), (1.04,0.79), (1.95,1.22)/ DATA DT8/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .68D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .68D0,-.87D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & .68D0,-.87D0,.15D0,.94D0, 0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .68D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .35D0,-.9D0,.48D0, 0.D0,0.D0,0.D0,0.D0, & .38D0,-.9D0,.57D0,.7D0,-.75D0,.2D0,.98D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .68D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .35D0,-.72D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & .38D0,-.63D0,.15D0,.88D0, 0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .68D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .68D0,-.9D0,.33D0, 0.D0,0.D0,0.D0,0.D0, & ! .68D0,-.9D0,.33D0,.7D0,-.75D0,.2D0,1.04D0/ DATA CT8/ & (.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.32,-1.41),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.32,-1.41),(-1.55,.5),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.32,-1.41),(-1.55,.5),(.03,-.89),(-.38,-.96),(0.,0.),(0.,0.), & (0.,0.), & (.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.32,-1.41),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (-.07,-.89),(-.9,.5),(.42,-1.41),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.78,.06),(-.9,.5),(.06,-.13),(.1,-.5),(-.77,-.49),(-.5,-.3), & (.52,-1.51), & (.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.32,-1.41),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (-.07,-.89),(-1.18,-.31),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.78,.06),(-1.54,.97),(.03,-.89),(-.18,-1.31),(0.,0.),(0.,0.), & (0.,0.),(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.32,-1.41),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.32,-1.41),(-.9,.5),(.05,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.32,-1.41),(-.9,.5),(.05,-.6),(.1,-.5),(-.77,-.49),(-.5,-.3), & ! ! ! TRUE X VALUES AFTER ROTATION USING SROT OR DROT. (.32,-1.16) / DATA DT9X/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .78D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .78D0,-.46D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & .78D0,-.46D0,-.22D0,1.06D0, 0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .78D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .66D0,.1D0,-.1D0, 0.D0,0.D0,0.D0,0.D0, & .96D0,.1D0,-.76D0,.8D0,.90D0,-.3D0,-.02D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .78D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & -.06D0,.1D0,-.1D0, 0.D0,0.D0,0.D0,0.D0, & .90D0,.1D0,-.22D0,.8D0,.18D0,-.3D0,-.02D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .78D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .78D0,.26D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & ! ! TRUE Y VALUES AFTER ROTATION USING SROT OR DROT. ! .78D0,.26D0,-.76D0,1.12D0, 0.D0,0.D0,0.D0/ DATA DT9Y/ .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .04D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .04D0,-.78D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & .04D0,-.78D0, .54D0, .08D0, 0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .04D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .7D0,-.9D0,-.12D0, 0.D0,0.D0,0.D0,0.D0, & .64D0,-.9D0,-.30D0, .7D0,-.18D0, .2D0, .28D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .04D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .7D0,-1.08D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & .64D0,-1.26D0,.54D0, .20D0, 0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .04D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .04D0,-.9D0, .18D0, 0.D0,0.D0,0.D0,0.D0, & ! .04D0,-.9D0, .18D0, .7D0,-.18D0, .2D0, .16D0/ DATA DT10X/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0,-.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0,-.9D0,.3D0,.7D0, 0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .3D0,.1D0 ,.5D0, 0.D0,0.D0,0.D0,0.D0, & .8D0,.1D0 ,-.6D0,.8D0 ,.3D0,-.3D0,.5D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & -.9D0,.1D0,.5D0, 0.D0,0.D0,0.D0,0.D0, & .7D0, .1D0,.3D0, .8D0,-.9D0,-.3D0,.5D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0,.3D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & ! .5D0,.3D0,-.6D0,.8D0, 0.D0,0.D0,0.D0/ DATA DT10Y/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0,.1D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0,.1D0,-.5D0,.8D0, 0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & -.5D0,-.9D0,.6D0, 0.D0,0.D0,0.D0,0.D0, & -.4D0,-.9D0,.9D0, .7D0,-.5D0, .2D0,.6D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & -.5D0,.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & -.4D0,.9D0,-.5D0,.6D0, 0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0,-.9D0,.1D0, 0.D0,0.D0,0.D0,0.D0, & ! .6D0,-.9D0,.1D0, .7D0,-.5D0, .2D0, .8D0/ DATA CT10X/ & (.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.6,-.6),(-.9,.5),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.6,-.6),(-.9,.5),(.7,-.6),(.1,-.5),(0.,0.),(0.,0.),(0.,0.), & (.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.7,-.6),(-.4,-.7),(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.8,-.7),(-.4,-.7),(-.1,-.2),(.2,-.8),(.7,-.6),(.1,.4),(.6,-.6), & (.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (-.9,.5),(-.4,-.7),(.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.1,-.5),(-.4,-.7),(.7,-.6),(.2,-.8),(-.9,.5),(.1,.4),(.6,-.6), & (.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.6,-.6),(.7,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & ! (.6,-.6),(.7,-.6),(-.1,-.2),(.8,-.7),(0.,0.),(0.,0.),(0.,0.) / DATA CT10Y/ & (.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.7,-.8),(-.4,-.7),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.7,-.8),(-.4,-.7),(-.1,-.9),(.2,-.8),(0.,0.),(0.,0.),(0.,0.), & (.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (-.1,-.9),(-.9,.5),(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (-.6,.6),(-.9,.5),(-.9,-.4),(.1,-.5),(-.1,-.9),(-.5,-.3),(.7,-.8), & (.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (-.1,-.9),(.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (-.6,.6),(-.9,-.4),(-.1,-.9),(.7,-.8),(0.,0.),(0.,0.),(0.,0.), & (.6,-.6),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.7,-.8),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (.7,-.8),(-.9,.5),(-.4,-.7),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & ! TRUE X RESULTS F0R ROTATIONS SROTM AND DROTM (.7,-.8),(-.9,.5),(-.4,-.7),(.1,-.5),(-.1,-.9),(-.5,-.3),(.2,-.8)/ DATA DT19XA/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, .1D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & -.8D0, 3.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & -.9D0, 2.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & 3.5D0, -.4D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, .1D0, -.5D0, .8D0, 0.D0,0.D0,0.D0, & -.8D0, 3.8D0, -2.2D0, -1.2D0, 0.D0,0.D0,0.D0, & -.9D0, 2.8D0, -1.4D0, -1.3D0, 0.D0,0.D0,0.D0, & ! 3.5D0, -.4D0, -2.2D0, 4.7D0, 0.D0,0.D0,0.D0/ DATA DT19XB/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, .1D0, -.5D0, 0.D0,0.D0,0.D0,0.D0, & 0.D0, .1D0, -3.0D0, 0.D0,0.D0,0.D0,0.D0, & -.3D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, & 3.3D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, & .6D0, .1D0, -.5D0, .8D0, .9D0, -.3D0, -.4D0, & -2.0D0, .1D0, 1.4D0, .8D0, .6D0, -.3D0, -2.8D0, & -1.8D0, .1D0, 1.3D0, .8D0, 0.D0, -.3D0, -1.9D0, & ! 3.8D0, .1D0, -3.1D0, .8D0, 4.8D0, -.3D0, -1.5D0 / DATA DT19XC/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, .1D0, -.5D0, 0.D0,0.D0,0.D0,0.D0, & 4.8D0, .1D0, -3.0D0, 0.D0,0.D0,0.D0,0.D0, & 3.3D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, & 2.1D0, .1D0, -2.0D0, 0.D0,0.D0,0.D0,0.D0, & .6D0, .1D0, -.5D0, .8D0, .9D0, -.3D0, -.4D0, & -1.6D0, .1D0, -2.2D0, .8D0, 5.4D0, -.3D0, -2.8D0, & -1.5D0, .1D0, -1.4D0, .8D0, 3.6D0, -.3D0, -1.9D0, & ! 3.7D0, .1D0, -2.2D0, .8D0, 3.6D0, -.3D0, -1.5D0 / DATA DT19XD/.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, .1D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & -.8D0, -1.0D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & -.9D0, -.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & 3.5D0, .8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & .6D0, .1D0, -.5D0, .8D0, 0.D0,0.D0,0.D0, & -.8D0, -1.0D0, 1.4D0, -1.6D0, 0.D0,0.D0,0.D0, & -.9D0, -.8D0, 1.3D0, -1.6D0, 0.D0,0.D0,0.D0, & ! TRUE Y RESULTS FOR ROTATIONS SROTM AND DROTM 3.5D0, .8D0, -3.1D0, 4.8D0, 0.D0,0.D0,0.D0/ DATA DT19YA/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & .7D0, -4.8D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & 1.7D0, -.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & -2.6D0, 3.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, -.9D0, .3D0, .7D0, 0.D0,0.D0,0.D0, & .7D0, -4.8D0, 3.0D0, 1.1D0, 0.D0,0.D0,0.D0, & 1.7D0, -.7D0, -.7D0, 2.3D0, 0.D0,0.D0,0.D0, & ! -2.6D0, 3.5D0, -.7D0, -3.6D0, 0.D0,0.D0,0.D0/ DATA DT19YB/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, -.9D0, .3D0, 0.D0,0.D0,0.D0,0.D0, & 4.0D0, -.9D0, -.3D0, 0.D0,0.D0,0.D0,0.D0, & -.5D0, -.9D0, 1.5D0, 0.D0,0.D0,0.D0,0.D0, & -1.5D0, -.9D0, -1.8D0, 0.D0,0.D0,0.D0,0.D0, & .5D0, -.9D0, .3D0, .7D0, -.6D0, .2D0, .8D0, & 3.7D0, -.9D0, -1.2D0, .7D0, -1.5D0, .2D0, 2.2D0, & -.3D0, -.9D0, 2.1D0, .7D0, -1.6D0, .2D0, 2.0D0, & ! -1.6D0, -.9D0, -2.1D0, .7D0, 2.9D0, .2D0, -3.8D0 / DATA DT19YC/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, -.9D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & 4.0D0, -6.3D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & -.5D0, .3D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & -1.5D0, 3.0D0, 0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, -.9D0, .3D0, .7D0, 0.D0,0.D0,0.D0, & 3.7D0, -7.2D0, 3.0D0, 1.7D0, 0.D0,0.D0,0.D0, & -.3D0, .9D0, -.7D0, 1.9D0, 0.D0,0.D0,0.D0, & ! -1.6D0, 2.7D0, -.7D0, -3.4D0, 0.D0,0.D0,0.D0/ DATA DT19YD/.5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & 1.7D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & -2.6D0, 0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & .5D0, -.9D0, .3D0, 0.D0,0.D0,0.D0,0.D0, & .7D0, -.9D0, 1.2D0, 0.D0,0.D0,0.D0,0.D0, & 1.7D0, -.9D0, .5D0, 0.D0,0.D0,0.D0,0.D0, & -2.6D0, -.9D0, -1.3D0, 0.D0,0.D0,0.D0,0.D0, & .5D0, -.9D0, .3D0, .7D0, -.6D0, .2D0, .8D0, & .7D0, -.9D0, 1.2D0, .7D0, -1.5D0, .2D0, 1.6D0, & 1.7D0, -.9D0, .5D0, .7D0, -1.6D0, .2D0, 2.4D0, & ! -2.6D0, -.9D0, -1.3D0, .7D0, 2.9D0, .2D0, -4.0D0 / DATA SSIZE1/ 0. , .3 , 1.6 , 3.2 / DATA DSIZE1/ 0.D0, .3D0, 1.6D0, 3.2D0 / ! ! FOR CDOTC AND CDOTU ! DATA SSIZE3/ .1, .4, 1.7, 3.3 / DATA CSIZE1/ (0.,0.), (.9,.9), (1.63,1.73), (2.90,2.78) / DATA SSIZE2/0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0., & 1.17,1.17,1.17,1.17,1.17,1.17,1.17, & 1.17,1.17,1.17,1.17,1.17,1.17,1.17/ DATA DSIZE2/0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0, & ! ! FOR CAXPY ! 1.17D0,1.17D0,1.17D0,1.17D0,1.17D0,1.17D0,1.17D0/ DATA CSIZE2/ & (0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.),(0.,0.), & (1.54,1.54),(1.54,1.54),(1.54,1.54),(1.54,1.54),(1.54,1.54), & ! ! FOR SROTM AND DROTM ! (1.54,1.54),(1.54,1.54) / DATA DPAR/-2.D0, 0.D0,0.D0,0.D0,0.D0, & -1.D0, 2.D0, -3.D0, -4.D0, 5.D0, & 0.D0, 0.D0, 2.D0, -3.D0, 0.D0, & !***FIRST EXECUTABLE STATEMENT CHECK2 1.D0, 5.D0, 2.D0, 0.D0, -4.D0/ DO 520 KI = 1, 4 INCX = INCXS(KI) INCY = INCYS(KI) MX = ABS(INCX) ! MY = ABS(INCY) DO 500 KN=1,4 N= NS(KN) KSIZE=MIN(2,KN) LENX = LENS(KN,MX) ! INITIALIZE ALL ARGUMENT ARRAYS. LENY = LENS(KN,MY) DO 5 I = 1, 7 SX(I) = DX1(I) SY(I) = DY1(I) DX(I) = DX1(I) DY(I) = DY1(I) CX(I) = CX1(I) ! ! BRANCH TO SELECT SUBPROGRAM TO BE TESTED. ! 5 CY(I) = CY1(I) GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, 90,100, & 110,999,999,140,150,999,999,180,190,200, & ! 1. SDOT 210,220,230,240,250), ICASE 10 call STEST(1,SDOT(N,SX,INCX,SY,INCY),REAL(DT7(KN,KI)), & SSIZE1(KN),SFAC,KPRINT) ! 2. DSDOT GO TO 500 20 call STEST(1,REAL(DSDOT(N,SX,INCX,SY,INCY)), & REAL(DT7(KN,KI)),SSIZE1(KN),SFAC,KPRINT) ! 3. SDSDOT GO TO 500 30 call STEST(1,SDSDOT(N,SB,SX,INCX,SY,INCY), & ST7B(KN,KI),SSIZE3(KN),SFAC,KPRINT) ! 4. DDOT GO TO 500 40 call DTEST(1,DDOT(N,DX,INCX,DY,INCY),DT7(KN,KI), & DSIZE1(KN),DFAC,KPRINT) ! 5. DQDOTI GO TO 500 ! ! DQDOTI AND DQDOTA ARE SUPPOSED TO USE EXTENDED ! PRECISION ARITHMETIC INTERNALLY. ! SET MODE = 1 OR 2 TO DISTINGUISH TESTS OF DQDOTI OR DQDOTA ! IN THE DIAGNOSTIC OUTPUT. ! 50 continue MODE = 1 call DTEST(1,DQDOTI(N,DB,QC,DX2,INCX,DY2,INCY), & DT2(KN,KI,1),DT2(KN,KI,1),DQFAC,KPRINT) ! ! 6. DQDOTA ! GO TO 500 ! ! TO TEST DQDOTA WE ACTUALLY TEST BOTH DQDOTI AND DQDOTA. ! THE OUTPUT VALUE OF QX FROM DQDOTI WILL BE USED AS INPUT ! TO DQDOTA. QX IS SUPPOSED TO BE IN A MACHINE-DEPENDENT ! EXTENDED PRECISION FORM. ! MODE IS SET TO 1 OR 2 TO DISTINGUISH TESTS OF ! DQDOTI OR DQDOTA IN THE DIAGNOSTIC OUTPUT. ! 60 continue MODE = 1 call DTEST(1,DQDOTI(N,DB,QC,DX2,INCX,DY2,INCY), & DT2(KN,KI,1),DT2(KN,KI,1),DQFAC,KPRINT) MODE = 2 call DTEST(1,DQDOTA(N,-DB,QC,DX2,INCX,DY2,INCY), & DT2(KN,KI,2),DT2(KN,KI,2),DQFAC,KPRINT) ! 7. CDOTC GO TO 500 70 call STEST(2, CDOTC(N,CX,INCX,CY,INCY), & CT6(KN,KI),CSIZE1(KN),SFAC,KPRINT) ! 8. CDOTU GO TO 500 80 call STEST(2,CDOTU(N,CX,INCX,CY,INCY), & CT7(KN,KI),CSIZE1(KN),SFAC,KPRINT) ! 9. SAXPY GO TO 500 90 call SAXPY(N,SA,SX,INCX,SY,INCY) DO 95 J = 1, LENY 95 STY(J) = DT8(J,KN,KI) call STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC,KPRINT) ! 10. DAXPY GO TO 500 100 call DAXPY(N,DA,DX,INCX,DY,INCY) call DTEST(LENY,DY,DT8(1,KN,KI),DSIZE2(1,KSIZE),DFAC,KPRINT) ! 11. CAXPY GO TO 500 110 call CAXPY(N,CA,CX,INCX,CY,INCY) call STEST(2*LENY,CY,CT8(1,KN,KI),CSIZE2(1,KSIZE),SFAC,KPRINT) ! 14. SROT GO TO 500 140 continue DO 144 I = 1, 7 SX(I) = DX1(I) SY(I) = DY1(I) STX(I) = DT9X(I,KN,KI) STY(I) = DT9Y(I,KN,KI) 144 continue call SROT (N,SX,INCX,SY,INCY,SC,SS) call STEST(LENX,SX,STX,SSIZE2(1,KSIZE),SFAC,KPRINT) call STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC,KPRINT) ! 15. DROT GO TO 500 150 continue DO 154 I = 1, 7 DX(I) = DX1(I) DY(I) = DY1(I) 154 continue call DROT (N,DX,INCX,DY,INCY,DC,DS) call DTEST(LENX,DX,DT9X(1,KN,KI),DSIZE2(1,KSIZE),DFAC,KPRINT) call DTEST(LENY,DY,DT9Y(1,KN,KI),DSIZE2(1,KSIZE),DFAC,KPRINT) ! 18. SROTM GO TO 500 180 KNI = KN + 4*(KI-1) DO 189 KPAR=1,4 DO 182 I = 1, 7 SX(I) = DX1(I) SY(I) = DY1(I) STX(I) = DT19X(I,KPAR,KNI) ! 182 STY(I) = DT19Y(I,KPAR,KNI) DO 186 I = 1, 5 ! SET MODE TO IDENTIFY DIAGNOSTIC OUTPUT, ! IF ANY 186 SPARAM(I) = DPAR(I,KPAR) ! MODE = INT(SPARAM(1)) DO 187 I = 1, LENX ! THE TRUE RESULTS DT19X(1,2,7) AND ! DT19X(5,3,8) ARE ZERO DUE TO CANCELLATION. ! DT19X(1,2,7) = 2.*.6 - 4.*.3 = 0 ! DT19X(5,3,8) = .9 - 3.*.3 = 0 ! FOR THESE CASES RESPECTIVELY SET SIZE( ) ! EQUAL TO 2.4 AND 1.8 187 SSIZE(I) = STX(I) if ( (KPAR == 2) .and. (KNI == 7)) & SSIZE(1) = 2.4E0 if ( (KPAR == 3) .and. (KNI == 8)) & ! SSIZE(5) = 1.8E0 call SROTM(N,SX,INCX,SY,INCY,SPARAM) call STEST(LENX,SX,STX,SSIZE,SFAC,KPRINT) call STEST(LENY,SY,STY,STY,SFAC,KPRINT) 189 continue ! 19. DROTM GO TO 500 190 KNI = KN + 4*(KI-1) DO 199 KPAR=1,4 DO 192 I = 1, 7 DX(I) = DX1(I) DY(I) = DY1(I) DTX(I) = DT19X(I,KPAR,KNI) ! 192 DTY(I) = DT19Y(I,KPAR,KNI) DO 196 I = 1, 5 ! SET MODE TO IDENTIFY DIAGNOSTIC OUTPUT, ! IF ANY 196 DPARAM(I) = DPAR(I,KPAR) ! MODE = INT(DPARAM(1)) DO 197 I = 1, LENX ! SEE REMARK ABOVE ABOUT DT11X(1,2,7) ! AND DT11X(5,3,8). 197 DSIZE(I) = DTX(I) if ( (KPAR == 2) .and. (KNI == 7)) & DSIZE(1) = 2.4D0 if ( (KPAR == 3) .and. (KNI == 8)) & ! DSIZE(5) = 1.8D0 call DROTM(N,DX,INCX,DY,INCY,DPARAM) call DTEST(LENX,DX,DTX,DSIZE,DFAC,KPRINT) call DTEST(LENY,DY,DTY,DTY,DFAC,KPRINT) 199 continue ! 20. SCOPY GO TO 500 200 DO 205 I = 1, 7 205 STY(I) = DT10Y(I,KN,KI) call SCOPY(N,SX,INCX,SY,INCY) call STEST(LENY,SY,STY,SSIZE2(1,1),1.,KPRINT) ! 21. DCOPY GO TO 500 210 call DCOPY(N,DX,INCX,DY,INCY) call DTEST(LENY,DY,DT10Y(1,KN,KI),DSIZE2(1,1),1.D0,KPRINT) ! 22. CCOPY GO TO 500 220 call CCOPY(N,CX,INCX,CY,INCY) call STEST(2*LENY,CY,CT10Y(1,KN,KI),SSIZE2(1,1),1.,KPRINT) ! 23. SSWAP GO TO 500 230 call SSWAP(N,SX,INCX,SY,INCY) DO 235 I = 1, 7 STX(I) = DT10X(I,KN,KI) 235 STY(I) = DT10Y(I,KN,KI) call STEST(LENX,SX,STX,SSIZE2(1,1),1.,KPRINT) call STEST(LENY,SY,STY,SSIZE2(1,1),1.,KPRINT) ! 24. DSWAP GO TO 500 240 call DSWAP(N,DX,INCX,DY,INCY) call DTEST(LENX,DX,DT10X(1,KN,KI),DSIZE2(1,1),1.D0,KPRINT) call DTEST(LENY,DY,DT10Y(1,KN,KI),DSIZE2(1,1),1.D0,KPRINT) ! 25. CSWAP GO TO 500 250 call CSWAP(N,CX,INCX,CY,INCY) call STEST(2*LENX,CX,CT10X(1,KN,KI),SSIZE2(1,1),1.,KPRINT) ! ! ! call STEST(2*LENY,CY,CT10Y(1,KN,KI),SSIZE2(1,1),1.,KPRINT) 500 continue 520 continue ! THE FOLLOWING STOP SHOULD NEVER BE REACHED. return 999 STOP end !! CHIQC !***PURPOSE Quick check for CHIFA, CHICO, CHISL and CHIDI. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS ! OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. ! THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C ! (THE SOLUTION VECTOR), AINV (INVERSE OF MATRIX A ), DC ! (DETERMINANT OF A ), AND RCND ( RCOND ) ARE ENTERED ! WITH DATA STATEMENTS. ! ! THE COMPUTED TEST RESULTS FOR X, RCOND, THE DETERMINANT, AND ! THE INVERSE ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. ! FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT ! DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH ! LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS ! PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. ! ! NO INPUT ARGUMENTS ARE REQUIRED. ! ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF ! ALL FAILURES DETECTED BY CHIQC. ! !***ROUTINES CALLED CHICO, CHIDI, CHIFA, CHISL !***REVISION HISTORY (YYMMDD) ! 801022 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if and cleaned up ! FORMATs. (RWC) !***END PROLOGUE CHIQC subroutine CHIQC (LUN, KPRINT, NERR) COMPLEX A(4,4),AT(5,4),B(4),BT(4),C(4),AINV(4,4), & Z(4),XA,XB REAL R,RCOND,RCND,DELX,DET(2),DC(2) CHARACTER KPROG*19,KFAIL*47 integer LDA,N,IPVT(4),INFO,I,J,INDX,NERR integer INERT(3),IRT(3) DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA AINV/(.66667E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,.33333E0),(.66667E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(.36364E0,0.E0),(0.E0,1.E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,.09091E0),(.27273E0,0.E0)/ DATA DC/3.3E0,1.0E0/ DATA KPROG/'HIFA HICO HISL HIDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE INERTIA'/ DATA RCND/.24099E0/ ! DATA IRT/4,0,0/ !***FIRST EXECUTABLE STATEMENT CHIQC DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) LDA = 5 N = 4 ! ! FORM AT FOR CHIFA AND BT FOR CHISL, TEST CHIFA ! NERR = 0 DO 20 J=1,N BT(J) = B(J) AT(1:n,J) = A(1:n,J) 20 continue call CHIFA(AT,LDA,N,IPVT,INFO) if ( INFO /= 0 ) then write (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ! ! TEST CHISL ! end if call CHISL(AT,LDA,N,IPVT,BT) INDX = 0 DO 40 I=1,N if ( DELX(C(I),BT(I)) > .0001) INDX=INDX+1 ! 40 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ! ! FORM AT FOR CHICO, TEST CHICO ! end if DO 70 J=1,N DO 60 I=1,N AT(I,J) = A(I,J) 60 continue ! 70 continue call CHICO(AT,LDA,N,IPVT,RCOND,Z) R = ABS(RCND-RCOND) if ( R >= .0001 ) then write (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ! ! TEST CHIDI FOR JOB=111 ! end if call CHIDI(AT,LDA,N,IPVT,DET,INERT,Z,111) INDX = 0 DO 110 I=1,2 if ( ABS(DC(I)-DET(I)) > .0001) INDX=INDX+1 ! 110 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ! end if INDX = 0 DO 140 I=1,N DO 130 J=1,N if ( DELX(AINV(I,J),AT(I,J)) > .0001) INDX=INDX+1 130 continue ! 140 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(33:39) NERR = NERR + 1 ! end if INDX = 0 DO 160 I=1,3 if ( (INERT(I)-IRT(I)) /= 0) INDX=INDX+1 ! 160 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(41:47) NERR = NERR + 1 ! end if if ( KPRINT >= 2 .OR. NERR /= 0) write (LUN,200) NERR ! return 200 FORMAT(/' * CHIQC - TEST FOR CHIFA, CHICO, CHISL AND CHIDI FOUND ' & , I1, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) end !! CHKXER !***SUBSIDIARY !***PURPOSE Test whether an error has been detected. !***LIBRARY SLATEC (BLAS) !***AUTHOR Du Croz, J. J., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! Tests whether an error has been detected. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED NUMXER !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CHKXER ! .. Scalar Arguments .. subroutine CHKXER (SRNAMT, INFOT, NOUT, FATAL, KPRINT) LOGICAL FATAL integer INFOT, KPRINT, NOUT ! .. Local Scalars .. CHARACTER*6 SRNAMT ! .. External Functions .. integer NERR integer NUMXER !***FIRST EXECUTABLE STATEMENT CHKXER EXTERNAL NUMXER if ( NUMXER(NERR) /= INFOT ) then FATAL = .TRUE. if ( kprint >= 3 ) then write ( NOUT, FMT = 9999 )INFOT, SRNAMT end if end if ! return 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', & ! ! End of CHKXER. ! 'ETECTED BY ', A6, ' *****' ) end !! CHPQC !***PURPOSE Quick check for CHPFA, CHPCO, CHPSL and CHPDI. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS ! OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. ! THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C ! (THE SOLUTION VECTOR), AINV (INVERSE OF MATRIX A ), DC ! (DETERMINANT OF A ), AND RCND ( RCOND ) ARE ENTERED ! WITH DATA STATEMENTS. ! ! THE COMPUTED TEST RESULTS FOR X, RCOND, THE DETERMINANT, AND ! THE INVERSE ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. ! FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT ! DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH ! LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS ! PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. ! ! NO INPUT ARGUMENTS ARE REQUIRED. ! ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF ! ALL FAILURES DETECTED BY CHPQC. ! !***ROUTINES CALLED CHPCO, CHPDI, CHPFA, CHPSL !***REVISION HISTORY (YYMMDD) ! 801022 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if and cleaned up ! FORMATs. (RWC) !***END PROLOGUE CHPQC subroutine CHPQC (LUN, KPRINT, NERR) COMPLEX AP(10),AT(10),B(4),BT(4),C(4),AINV(10), & Z(4),XA,XB REAL R,RCOND,RCND,DELX,DET(2),DC(2) CHARACTER KPROG*19, KFAIL*47 integer N,IPVT(4),INFO,I,J,INDX,NERR integer INERT(3),IRT(3) DATA AP/(2.E0,0.E0),(0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(3.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA AINV/(.66667E0,0.E0),(0.E0,.33333E0),(.66667E0,0.E0), & (0.E0,0.E0), & (0.E0,0.E0),(.36364E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,.09091E0),(.27273E0,0.E0)/ DATA DC/3.3E0,1.0E0/ DATA KPROG/'HPFA HPCO HPSL HPDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE INERTIA'/ DATA RCND/.24099E0/ ! DATA IRT/4,0,0/ !***FIRST EXECUTABLE STATEMENT CHPQC DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) N = 4 ! ! FORM AT FOR CHPFA AND BT FOR CHPSL, TEST CHPFA ! NERR = 0 BT(1:n) = B(1:n) DO 20 I=1,10 AT(I) = AP(I) ! 20 continue call CHPFA(AT,N,IPVT,INFO) if ( INFO /= 0 ) then write (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ! ! TEST CHPSL ! end if call CHPSL(AT,N,IPVT,BT) INDX = 0 DO 40 I=1,N if ( DELX(C(I),BT(I)) > .0001) INDX=INDX+1 ! 40 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ! ! FORM AT FOR CHPCO, TEST CHPCO ! end if DO 70 I=1,10 AT(I) = AP(I) ! 70 continue call CHPCO(AT,N,IPVT,RCOND,Z) R = ABS(RCND-RCOND) if ( R >= .0001 ) then write (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ! ! TEST CHPDI FOR JOB=111 ! end if call CHPDI(AT,N,IPVT,DET,INERT,Z,111) INDX = 0 DO 110 I=1,2 if ( ABS(DC(I)-DET(I)) > .0001) INDX=INDX+1 ! 110 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ! end if INDX = 0 DO 140 I=1,10 if ( DELX(AINV(I),AT(I)) > .0001) INDX=INDX+1 ! 140 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(33:39) NERR = NERR + 1 ! end if INDX = 0 DO 160 I=1,3 if ( (INERT(I)-IRT(I)) /= 0) INDX=INDX+1 ! 160 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(41:47) NERR = NERR + 1 ! end if if ( KPRINT >= 2 .OR. NERR /= 0) write (LUN,200) NERR ! return 200 FORMAT(/' * CHPQC - TEST FOR CHPFA, CHPCO, CHPSL AND CHPDI FOUND ' & , I1, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) end subroutine CMAKE2 (TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, & !! CMAKE2 !***SUBSIDIARY !***PURPOSE Generate values for an M by N matrix A. !***LIBRARY SLATEC (BLAS) !***AUTHOR Du Croz, J. J., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! Generates values for an M by N matrix A within the bandwidth ! defined by KL and KU. ! Stores the values in the array AA in the data structure required ! by the routine, with unwanted elements set to rogue value. ! ! TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CBEG !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CMAKE2 ! .. Parameters .. KU, RESET, TRANSL) COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) COMPLEX ROGUE PARAMETER ( ROGUE = ( -1.0E10, 1.0E10 ) ) REAL RZERO PARAMETER ( RZERO = 0.0 ) REAL RROGUE ! .. Scalar Arguments .. PARAMETER ( RROGUE = -1.0E10 ) COMPLEX TRANSL integer KL, KU, LDA, M, N, NMAX LOGICAL RESET CHARACTER*1 DIAG, UPLO ! .. Array Arguments .. CHARACTER*2 TYPE ! .. Local Scalars .. COMPLEX A( NMAX, * ), AA( * ) integer I, I1, I2, I3, IBEG, IEND, IOFF, J, JJ, KK ! .. External Functions .. LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER COMPLEX CBEG ! .. Intrinsic Functions .. EXTERNAL CBEG !***FIRST EXECUTABLE STATEMENT CMAKE2 INTRINSIC CMPLX, CONJG, MAX, MIN, REAL GEN = TYPE( 1: 1 ) == 'G' SYM = TYPE( 1: 1 ) == 'H' TRI = TYPE( 1: 1 ) == 'T' UPPER = ( SYM.OR.TRI ) .and. UPLO == 'U' LOWER = ( SYM.OR.TRI ) .and. UPLO == 'L' ! ! Generate data in array A. ! UNIT = TRI .and. DIAG == 'U' DO 20 J = 1, N DO I = 1, M if ( GEN.OR.( UPPER .and. I <= J ).OR.( LOWER.AND.I >= J ) ) & THEN if ( ( I <= J .and. J - I <= KU ).OR. & ( I >= J .and. I - J <= KL ) ) then A( I, J ) = CBEG( RESET ) + TRANSL else A( I, J ) = ZERO end if if ( I /= J ) then if ( SYM ) then A( J, I ) = CONJG( A( I, J ) ) else if ( TRI ) then A( J, I ) = ZERO end if end if end if end do if ( SYM ) & A( J, J ) = CMPLX( REAL( A( J, J ) ), RZERO ) if ( TRI ) & A( J, J ) = A( J, J ) + ONE if ( UNIT ) & A( J, J ) = ONE ! ! Store elements in array AS in data structure required by routine. ! 20 continue if ( TYPE == 'GE' ) then DO 50 J = 1, N DO 30 I = 1, M AA( I + ( J - 1 )*LDA ) = A( I, J ) 30 continue DO 40 I = M + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 40 continue 50 continue else if ( TYPE == 'GB' ) then DO 90 J = 1, N DO 60 I1 = 1, KU + 1 - J AA( I1 + ( J - 1 )*LDA ) = ROGUE 60 continue DO 70 I2 = I1, min ( KL + KU + 1, KU + 1 + M - J ) AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) 70 continue DO 80 I3 = I2, LDA AA( I3 + ( J - 1 )*LDA ) = ROGUE 80 continue 90 continue else if ( TYPE == 'HE'.OR.TYPE == 'TR' ) then DO 130 J = 1, N if ( UPPER ) then IBEG = 1 if ( UNIT ) then IEND = J - 1 else IEND = J end if else if ( UNIT ) then IBEG = J + 1 else IBEG = J end if IEND = N end if DO I = 1, IBEG - 1 AA( I + ( J - 1 )*LDA ) = ROGUE end do DO 110 I = IBEG, IEND AA( I + ( J - 1 )*LDA ) = A( I, J ) 110 continue DO 120 I = IEND + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 120 continue if ( SYM ) then JJ = J + ( J - 1 )*LDA AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) end if 130 continue else if ( TYPE == 'HB'.OR.TYPE == 'TB' ) then DO 170 J = 1, N if ( UPPER ) then KK = KL + 1 IBEG = max ( 1, KL + 2 - J ) if ( UNIT ) then IEND = KL else IEND = KL + 1 end if else KK = 1 if ( UNIT ) then IBEG = 2 else IBEG = 1 end if IEND = min ( KL + 1, 1 + M - J ) end if DO 140 I = 1, IBEG - 1 AA( I + ( J - 1 )*LDA ) = ROGUE 140 continue DO 150 I = IBEG, IEND AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) 150 continue DO 160 I = IEND + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 160 continue if ( SYM ) then JJ = KK + ( J - 1 )*LDA AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) end if 170 continue else if ( TYPE == 'HP'.OR.TYPE == 'TP' ) then IOFF = 0 DO 190 J = 1, N if ( UPPER ) then IBEG = 1 IEND = J else IBEG = J IEND = N end if DO 180 I = IBEG, IEND IOFF = IOFF + 1 AA( IOFF ) = A( I, J ) if ( I == J ) then if ( UNIT ) & AA( IOFF ) = ROGUE if ( SYM ) & AA( IOFF ) = CMPLX( REAL( AA( IOFF ) ), RROGUE ) end if 180 continue 190 continue end if ! ! End of CMAKE2. ! return end subroutine CMAKE3 (TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, & !! CMAKE3 !***SUBSIDIARY !***PURPOSE Generate values for an M by N matrix A. !***LIBRARY SLATEC (BLAS) !***AUTHOR Dongarra, J. J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) !***DESCRIPTION ! ! Generates values for an M by N matrix A within the bandwidth ! defined by KL and KU. ! Stores the values in the array AA in the data structure required ! by the routine, with unwanted elements set to rogue value. ! ! TYPE is 'GE', 'HE', 'SY', OR 'TR'. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CBEG !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CMAKE3 ! .. Parameters .. RESET, TRANSL) COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) COMPLEX ROGUE PARAMETER ( ROGUE = ( -1.0E10, 1.0E10 ) ) REAL RZERO PARAMETER ( RZERO = 0.0 ) REAL RROGUE ! .. Scalar Arguments .. PARAMETER ( RROGUE = -1.0E10 ) COMPLEX TRANSL integer LDA, M, N, NMAX LOGICAL RESET CHARACTER*1 DIAG, UPLO ! .. Array Arguments .. CHARACTER*2 TYPE ! .. Local Scalars .. COMPLEX A( NMAX, * ), AA( * ) integer I, IBEG, IEND, J, JJ ! .. External Functions .. LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER, HER COMPLEX CBEG ! .. Intrinsic Functions .. EXTERNAL CBEG !***FIRST EXECUTABLE STATEMENT CMAKE3 INTRINSIC CMPLX, CONJG, REAL GEN = TYPE == 'GE' HER = TYPE == 'HE' SYM = TYPE == 'SY' TRI = TYPE == 'TR' UPPER = ( HER.OR.SYM.OR.TRI ) .and. UPLO == 'U' LOWER = ( HER.OR.SYM.OR.TRI ) .and. UPLO == 'L' ! ! Generate data in array A. ! UNIT = TRI .and. DIAG == 'U' DO 20 J = 1, N DO I = 1, M if ( GEN.OR.( UPPER .and. I <= J ).OR.( LOWER.AND.I >= J ) ) & THEN A( I, J ) = CBEG( RESET ) + TRANSL ! Set some elements to zero if ( I /= J ) then if ( N > 3 .and. J == N/2 ) & A( I, J ) = ZERO if ( HER ) then A( J, I ) = CONJG( A( I, J ) ) else if ( SYM ) then A( J, I ) = A( I, J ) else if ( TRI ) then A( J, I ) = ZERO end if end if end if end do if ( HER ) & A( J, J ) = CMPLX( REAL( A( J, J ) ), RZERO ) if ( TRI ) & A( J, J ) = A( J, J ) + ONE if ( UNIT ) & A( J, J ) = ONE ! ! Store elements in array AS in data structure required by routine. ! 20 continue if ( TYPE == 'GE' ) then DO 50 J = 1, N DO 30 I = 1, M AA( I + ( J - 1 )*LDA ) = A( I, J ) 30 continue DO 40 I = M + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 40 continue 50 continue else if ( TYPE == 'HE'.OR.TYPE == 'SY'.OR.TYPE == 'TR' ) then DO 90 J = 1, N if ( UPPER ) then IBEG = 1 if ( UNIT ) then IEND = J - 1 else IEND = J end if else if ( UNIT ) then IBEG = J + 1 else IBEG = J end if IEND = N end if DO 60 I = 1, IBEG - 1 AA( I + ( J - 1 )*LDA ) = ROGUE 60 continue DO 70 I = IBEG, IEND AA( I + ( J - 1 )*LDA ) = A( I, J ) 70 continue DO 80 I = IEND + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 80 continue if ( HER ) then JJ = J + ( J - 1 )*LDA AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) end if 90 continue end if ! ! End of CMAKE3. ! return end subroutine CMMCH (TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, & !! CMMCH !***SUBSIDIARY !***PURPOSE Check the results of the computational tests. !***LIBRARY SLATEC (BLAS) !***AUTHOR Dongarra, J. J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) !***DESCRIPTION ! ! Checks the results of the computational tests. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CMMCH ! .. Parameters .. BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FTL, NOUT, MV, KPRINT) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0, 0.0 ) ) REAL RZERO, RONE ! .. Scalar Arguments .. PARAMETER ( RZERO = 0.0, RONE = 1.0 ) LOGICAL FTL COMPLEX ALPHA, BETA REAL EPS, ERR integer KK, KPRINT, LDA, LDB, LDC, LDCC, M, N, NOUT LOGICAL MV ! .. Array Arguments .. CHARACTER*1 TRANSA, TRANSB COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ), & CC( LDCC, * ), CT( * ) ! .. Local Scalars .. REAL G( * ) COMPLEX CL REAL ERRI integer I, J, K ! .. Intrinsic Functions .. LOGICAL CTRANA, CTRANB, TRANA, TRANB ! .. Statement Functions .. INTRINSIC ABS, AIMAG, CONJG, MAX, REAL, SQRT ! .. Statement Function definitions .. REAL ABS1 !***FIRST EXECUTABLE STATEMENT CMMCH ABS1( CL ) = ABS( REAL( CL ) ) + ABS( AIMAG( CL ) ) TRANA = TRANSA == 'T'.OR.TRANSA == 'C' TRANB = TRANSB == 'T'.OR.TRANSB == 'C' CTRANA = TRANSA == 'C' ! ! Compute expected result, one column at a time, in CT using data ! in A, B and C. ! Compute gauges in G. ! CTRANB = TRANSB == 'C' ! DO 220 J = 1, N CT(1:m) = ZERO G(1:m) = RZERO if ( .NOT.TRANA .and. .NOT.TRANB ) then DO 30 K = 1, KK DO 20 I = 1, M CT( I ) = CT( I ) + A( I, K )*B( K, J ) G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) ) 20 continue 30 continue else if ( TRANA .and. .NOT.TRANB ) then if ( CTRANA ) then DO 50 K = 1, KK DO 40 I = 1, M CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( K, J ) G( I ) = G( I ) + ABS1( A( K, I ) )* & ABS1( B( K, J ) ) 40 continue 50 continue else DO 70 K = 1, KK DO 60 I = 1, M CT( I ) = CT( I ) + A( K, I )*B( K, J ) G( I ) = G( I ) + ABS1( A( K, I ) )* & ABS1( B( K, J ) ) 60 continue 70 continue end if else if ( .NOT.TRANA .and. TRANB ) then if ( CTRANB ) then DO 90 K = 1, KK DO 80 I = 1, M CT( I ) = CT( I ) + A( I, K )*CONJG( B( J, K ) ) G( I ) = G( I ) + ABS1( A( I, K ) )* & ABS1( B( J, K ) ) 80 continue 90 continue else DO K = 1, KK DO I = 1, M CT( I ) = CT( I ) + A( I, K )*B( J, K ) G( I ) = G( I ) + ABS1( A( I, K ) )* & ABS1( B( J, K ) ) end do end do end if else if ( TRANA .and. TRANB ) then if ( CTRANA ) then if ( CTRANB ) then DO 130 K = 1, KK DO 120 I = 1, M CT( I ) = CT( I ) + CONJG( A( K, I ) )* & CONJG( B( J, K ) ) G( I ) = G( I ) + ABS1( A( K, I ) )* & ABS1( B( J, K ) ) 120 continue 130 continue else DO 150 K = 1, KK DO 140 I = 1, M CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( J, K ) G( I ) = G( I ) + ABS1( A( K, I ) )* & ABS1( B( J, K ) ) 140 continue 150 continue end if else if ( CTRANB ) then DO 170 K = 1, KK DO 160 I = 1, M CT( I ) = CT( I ) + A( K, I )*CONJG( B( J, K ) ) G( I ) = G( I ) + ABS1( A( K, I ) )* & ABS1( B( J, K ) ) 160 continue 170 continue else DO 190 K = 1, KK DO 180 I = 1, M CT( I ) = CT( I ) + A( K, I )*B( J, K ) G( I ) = G( I ) + ABS1( A( K, I ) )* & ABS1( B( J, K ) ) 180 continue 190 continue end if end if end if DO 200 I = 1, M CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) G( I ) = ABS1( ALPHA )*G( I ) + & ABS1( BETA )*ABS1( C( I, J ) ) ! ! Compute the error ratio for this result. ! 200 continue ERR = ZERO DO 210 I = 1, M ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS if ( G( I ) /= RZERO ) & ERRI = ERRI/G( I ) ERR = max ( ERR, ERRI ) if ( ERR*SQRT( EPS ) >= RONE ) then FTL = .TRUE. if ( kprint >= 2 ) then write ( NOUT, FMT = 9999 ) DO 240 K = 1, M if ( MV ) then write ( NOUT, FMT = 9998 )K, CT( K ), CC( K, J ) else write ( NOUT, FMT = 9998 )K, CC( K, J ), CT( K ) end if 240 continue end if end if 210 continue 220 continue ! return 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', & 'F ACCURATE *******', /' EXPECTED RE', & 'SULT COMPUTED RESULT' ) ! ! End of CMMCH. ! 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) end !! CMPARE !***PURPOSE Compare values in COMMON block CHECK for quick check ! routine PFITQX. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CMPARE-S, DCMPAR-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***COMMON BLOCKS CHECK !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890921 Realigned order of variables in the COMMON block. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920214 Minor improvements to code for readability. (WRB) !***END PROLOGUE CMPARE ! .. Scalar Arguments .. subroutine CMPARE (ICNT, ITEST) ! .. Array Arguments .. integer ICNT ! .. Scalars in Common .. integer ITEST(9) REAL EPS, RP, SVEPS, TOL ! .. Arrays in Common .. integer IERP, IERR, NORD, NORDP ! .. Local Scalars .. REAL R(11) REAL RPP, SS ! .. Local Arrays .. integer IERPP, NRDP ! .. Intrinsic Functions .. integer ITEMP(4) ! .. Common blocks .. INTRINSIC ABS !***FIRST EXECUTABLE STATEMENT CMPARE COMMON /CHECK/ EPS, R, RP, SVEPS, TOL, NORDP, NORD, IERP, IERR ICNT = ICNT + 1 ITEMP(1) = 0 ITEMP(2) = 0 ITEMP(3) = 0 ITEMP(4) = 0 SS = SVEPS - EPS NRDP = NORDP - NORD RPP = RP - R(11) IERPP = IERP - IERR if ( ABS(SS) <= TOL .OR. ICNT <= 2 .OR. ICNT >= 6) ITEMP(1) = 1 if ( ABS(NRDP) == 0) ITEMP(2) = 1 if ( ABS(RPP) <= TOL) ITEMP(3) = 1 ! ! Check to see if all four tests were good. ! If so, set the test number equal to 1. ! if ( ABS(IERPP) == 0) ITEMP(4) = 1 ITEST(ICNT) = ITEMP(1)*ITEMP(2)*ITEMP(3)*ITEMP(4) return end subroutine CMVCH (TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, & !! CMVCH !***SUBSIDIARY !***PURPOSE Check the results of the computational tests. !***LIBRARY SLATEC (BLAS) !***AUTHOR Du Croz, J. J., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! Checks the results of the computational tests. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE CMVCH ! .. Parameters .. INCY, YT, G, YY, EPS, ERR, FTL, NOUT, MV, KPRINT) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0, 0.0 ) ) REAL RZERO, RONE ! .. Scalar Arguments .. PARAMETER ( RZERO = 0.0, RONE = 1.0 ) COMPLEX ALPHA, BETA REAL EPS, ERR integer INCX, INCY, KPRINT, M, N, NMAX, NOUT LOGICAL MV, FTL ! .. Array Arguments .. CHARACTER*1 TRANS COMPLEX A( NMAX, * ), X( * ), Y( * ), YT( * ), YY( * ) ! .. Local Scalars .. REAL G( * ) COMPLEX C REAL ERRI integer I, INCXL, INCYL, IY, J, JX, K, KX, KY, ML, NL ! .. Intrinsic Functions .. LOGICAL CTRAN, TRAN ! .. Statement Functions .. INTRINSIC ABS, AIMAG, CONJG, MAX, REAL, SQRT ! .. Statement Function definitions .. REAL ABS1 !***FIRST EXECUTABLE STATEMENT CMVCH ABS1( C ) = ABS( REAL( C ) ) + ABS( AIMAG( C ) ) TRAN = TRANS == 'T' CTRAN = TRANS == 'C' if ( TRAN.OR.CTRAN ) then ML = N NL = M else ML = M NL = N end if if ( INCX < 0 ) then KX = NL INCXL = -1 else KX = 1 INCXL = 1 end if if ( INCY < 0 ) then KY = ML INCYL = -1 else KY = 1 INCYL = 1 ! ! Compute expected result in YT using data in A, X and Y. ! Compute gauges in G. ! end if IY = KY DO 40 I = 1, ML YT( IY ) = ZERO G( IY ) = RZERO JX = KX if ( TRAN ) then DO J = 1, NL YT( IY ) = YT( IY ) + A( J, I )*X( JX ) G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) JX = JX + INCXL end do else if ( CTRAN ) then DO 20 J = 1, NL YT( IY ) = YT( IY ) + CONJG( A( J, I ) )*X( JX ) G( IY ) = G( IY ) + ABS1( A( J, I ) )*ABS1( X( JX ) ) JX = JX + INCXL 20 continue else DO 30 J = 1, NL YT( IY ) = YT( IY ) + A( I, J )*X( JX ) G( IY ) = G( IY ) + ABS1( A( I, J ) )*ABS1( X( JX ) ) JX = JX + INCXL 30 continue end if YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) G( IY ) = ABS1( ALPHA )*G( IY ) + ABS1( BETA )*ABS1( Y( IY ) ) IY = IY + INCYL ! ! Compute the error ratio for this result. ! 40 continue ERR = ZERO DO 50 I = 1, ML ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS if ( G( I ) /= RZERO ) & ERRI = ERRI/G( I ) ERR = max ( ERR, ERRI ) if ( ERR*SQRT( EPS ) >= RONE ) then FTL = .TRUE. if ( kprint >= 2 ) then write ( NOUT, FMT = 9999 ) DO 70 K = 1, ML if ( MV ) then write ( NOUT, FMT = 9998 )K, YT( K ), & YY( 1 + ( K - 1 )*ABS( INCY ) ) else write ( NOUT, FMT = 9998 )I, & YY( 1 + ( K - 1 )*ABS( INCY ) ), YT( K ) end if 70 continue end if ! end if 50 continue ! return 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', & 'F ACCURATE *******', /' EXPECTED RE', & 'SULT COMPUTED RESULT' ) ! ! End of CMVCH. ! 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) end !! COMP !***SUBSIDIARY !***PURPOSE Compare actual and expected values of error flag. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK SERVICE ROUTINE !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! COMPARE ACTUAL VALUE OF IERR WITH EXPECTED VALUE. ! PRINT ERROR MESSAGE IF THEY DON'T AGREE. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 890706 Cosmetic changes to prologue. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 Revised prologue. (FNF) ! 900316 Minor modification to format 5010. (FNF) ! 910708 Minor modifications in use of KPRINT. (WRB) !***END PROLOGUE COMP LOGICAL FUNCTION COMP (IERACT, IEREXP, LOUT, KPRINT) !***FIRST EXECUTABLE STATEMENT COMP integer IERACT, IEREXP, LOUT, KPRINT if ( IERACT == IEREXP) THEN COMP = .TRUE. if ( kprint >= 3) write (LOUT, 5010) 5010 FORMAT (' OK.') else COMP = .FALSE. if ( kprint >= 3) write (LOUT, 5020) IERACT 5020 FORMAT (' *** COMPARE FAILED -- IERR =',I5) ! end if ! -------- LAST LINE OF COMP FOLLOWS ----------------------------- return end !! CPBQC !***PURPOSE Quick check for CPBFA, CPBCO, CPBSL and CPBDI. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS ! OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. ! THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C ! (THE SOLUTION VECTOR), DC (DETERMINANT OF A ), AND ! RCND (RCOND) ARE ENTERED WITH DATA STATEMENTS. ! ! THE COMPUTED TEST RESULTS FOR X, RCOND AND THE DETER- ! MINANT ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. ! FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT ! DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH ! LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS ! PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. ! ! NO INPUT ARGUMENTS ARE REQUIRED. ! ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF ! ALL FAILURES DETECTED BY CPBQC. ! !***ROUTINES CALLED CPBCO, CPBDI, CPBFA, CPBSL !***REVISION HISTORY (YYMMDD) ! 801020 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if and cleaned up ! FORMATs. (RWC) !***END PROLOGUE CPBQC subroutine CPBQC (LUN, KPRINT, NERR) COMPLEX ABD(2,4),AT(3,4),B(4),BT(4),C(4), & Z(4),XA,XB REAL R,RCOND,RCND,DELX,DET(2),DC(2) CHARACTER KPROG*19, KFAIL*39 integer LDA,N,INFO,I,J,INDX,NERR,M DATA ABD/(0.E0,0.E0),(2.E0,0.E0),(0.E0,-1.E0),(2.E0,0.E0), & (0.E0,0.E0),(3.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA DC/3.3E0,1.0E0/ DATA KPROG/'PBFA PBCO PBSL PBDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE'/ ! DATA RCND/.24099E0/ !***FIRST EXECUTABLE STATEMENT CPBQC DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) LDA = 3 N = 4 M = 1 ! ! FORM AT FOR CPBFA AND BT FOR CPBSL, TEST CPBFA ! NERR = 0 DO 20 J=1,N BT(J) = B(J) AT(1:2,J) = ABD(1:2,J) 20 continue call CPBFA(AT,LDA,N,M,INFO) if ( INFO /= 0 ) then write (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ! ! TEST CPBSL ! end if call CPBSL(AT,LDA,N,M,BT) INDX = 0 DO 40 I=1,N if ( DELX(C(I),BT(I)) > .0001) INDX=INDX+1 ! 40 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ! ! FORM AT FOR CPBCO, TEST CPBCO ! end if DO 70 J=1,N DO 60 I=1,2 AT(I,J) = ABD(I,J) 60 continue ! 70 continue call CPBCO(AT,LDA,N,M,RCOND,Z,INFO) R = ABS(RCND-RCOND) if ( R >= .0001 ) then write (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ! end if if ( INFO /= 0 ) then write (LUN,201) KPROG(6:9),KFAIL(1:4) NERR = NERR + 1 ! ! TEST CPBDI ! end if call CPBDI(AT,LDA,N,M,DET) INDX = 0 DO 110 I=1,2 if ( ABS(DC(I)-DET(I)) > .0001) INDX=INDX+1 ! 110 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ! end if if ( KPRINT >= 2 .OR. NERR /= 0) write (LUN,200) NERR ! return 200 FORMAT(/' * CPBQC - TEST FOR CPBFA, CPBCO, CPBSL AND CPBDI FOUND ' & , I1, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) end !! CPOQC !***PURPOSE Quick check for CPOFA, CPOCO, CPOSL and CPODI. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS ! OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. ! THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C ! (THE SOLUTION VECTOR), AINV (INVERSE OF MATRIX A ), DC ! (DETERMINANT OF A ), AND RCND ( RCOND ) ARE ENTERED ! WITH DATA STATEMENTS. ! ! THE COMPUTED TEST RESULTS FOR X, RCOND, THE DETERMINANT, AND ! THE INVERSE ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. ! FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT ! DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH ! LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS ! PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. ! ! NO INPUT ARGUMENTS ARE REQUIRED. ! ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF ! ALL FAILURES DETECTED BY CPOQC. ! !***ROUTINES CALLED CPOCO, CPODI, CPOFA, CPOSL !***REVISION HISTORY (YYMMDD) ! 801016 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if and cleaned up ! FORMATs. (RWC) !***END PROLOGUE CPOQC subroutine CPOQC (LUN, KPRINT, NERR) COMPLEX A(4,4),AT(5,4),B(4),BT(4),C(4),AINV(4,4), & Z(4),XA,XB REAL R,RCOND,RCND,DELX,DET(2),DC(2) CHARACTER KPROG*19,KFAIL*39 integer LDA,N,INFO,I,J,INDX,NERR DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA AINV/(.66667E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,.33333E0),(.66667E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(.36364E0,0.E0),(0.E0,1.E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,.09091E0),(.27273E0,0.E0)/ DATA DC/3.3E0,1.0E0/ DATA KPROG/'POFA POCO POSL PODI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE'/ ! DATA RCND/.24099E0/ !***FIRST EXECUTABLE STATEMENT CPOQC DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) LDA = 5 N = 4 ! ! FORM AT FOR CPOFA AND BT FOR CPOSL, TEST CPOFA ! NERR = 0 DO 20 J=1,N BT(J) = B(J) AT(1:n,J) = A(1:n,J) 20 continue call CPOFA(AT,LDA,N,INFO) if ( INFO /= 0 ) then write (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ! ! TEST CPOSL ! end if call CPOSL(AT,LDA,N,BT) INDX = 0 DO 40 I=1,N if ( DELX(C(I),BT(I)) > .0001) INDX=INDX+1 ! 40 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ! ! FORM AT FOR CPOCO, TEST CPOCO ! end if DO 70 J=1,N DO 60 I=1,N AT(I,J) = A(I,J) 60 continue ! 70 continue call CPOCO(AT,LDA,N,RCOND,Z,INFO) R = ABS(RCND-RCOND) if ( R >= .0001 ) then write (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ! end if if ( INFO /= 0 ) then write (LUN,201) KPROG(6:9),KFAIL(1:4) NERR = NERR + 1 ! ! TEST CPODI FOR JOB=11 ! end if call CPODI(AT,LDA,N,DET,11) INDX = 0 DO 110 I=1,2 if ( ABS(DC(I)-DET(I)) > .0001) INDX=INDX+1 ! 110 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ! end if INDX = 0 DO 140 I=1,N DO 130 J=1,N if ( DELX(AINV(I,J),AT(I,J)) > .0001) INDX=INDX+1 130 continue ! 140 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(33:39) NERR = NERR + 1 ! ! end if if ( KPRINT >= 2 .OR. NERR /= 0) write (LUN,200) NERR ! return 200 FORMAT(/' * CPOQC - TEST FOR CPOFA, CPOCO, CPOSL AND CPODI FOUND ' & , I1, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) end !! CPPQC !***PURPOSE Quick check for CPPFA, CPPCO, CPPSL and CPPDI. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS ! OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. ! THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C ! (THE SOLUTION VECTOR), AINV (INVERSE OF MATRIX A ), DC ! (DETERMINANT OF A ), AND RCND ( RCOND ) ARE ENTERED ! WITH DATA STATEMENTS. ! ! THE COMPUTED TEST RESULTS FOR X, RCOND, THE DETERMINANT, AND ! THE INVERSE ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. ! FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT ! DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH ! LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS ! PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. ! ! NO INPUT ARGUMENTS ARE REQUIRED. ! ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF ! ALL FAILURES DETECTED BY CPPQC. ! !***ROUTINES CALLED CPPCO, CPPDI, CPPFA, CPPSL !***REVISION HISTORY (YYMMDD) ! 801016 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if and cleaned up ! FORMATs. (RWC) !***END PROLOGUE CPPQC subroutine CPPQC (LUN, KPRINT, NERR) COMPLEX AP(10),AT(10),B(4),BT(4),C(4),AINV(10), & Z(4),XA,XB REAL R,RCOND,RCND,DELX,DET(2),DC(2) CHARACTER KPROG*19, KFAIL*39 integer N,INFO,I,J,INDX,NERR DATA AP/(2.E0,0.E0),(0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(3.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA AINV/(.66667E0,0.E0),(0.E0,.33333E0),(.66667E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(.36364E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,.09091E0),(.27273E0,0.E0)/ DATA DC/3.3E0,1.0E0/ DATA KPROG/'PPFA PPCO PPSL PPDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE'/ ! DATA RCND/.24099E0/ !***FIRST EXECUTABLE STATEMENT CPPQC DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) N = 4 ! ! FORM AT FOR CPPFA AND BT FOR CPPSL, TEST CPPFA ! NERR = 0 BT(1:n) = B(1:n) DO 20 I=1,10 AT(I) = AP(I) 20 continue call CPPFA(AT,N,INFO) if ( INFO /= 0 ) then write (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ! ! TEST CPPSL ! end if call CPPSL(AT,N,BT) INDX = 0 DO 40 I=1,N if ( DELX(C(I),BT(I)) > .0001) INDX=INDX+1 ! 40 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ! ! FORM AT FOR CPPCO, TEST CPPCO ! end if DO 60 I=1,10 AT(I) = AP(I) ! 60 continue call CPPCO(AT,N,RCOND,Z,INFO) R = ABS(RCND-RCOND) if ( R >= .0001 ) then write (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ! end if if ( INFO /= 0 ) then write (LUN,201) KPROG(6:9),KFAIL(1:4) NERR = NERR + 1 ! ! TEST CPPDI FOR JOB=11 ! end if call CPPDI(AT,N,DET,11) INDX = 0 DO 110 I=1,2 if ( ABS(DC(I)-DET(I)) > .0001) INDX=INDX+1 ! 110 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ! end if INDX = 0 DO 140 I=1,10 if ( DELX(AINV(I),AT(I)) > .0001) INDX=INDX+1 ! 140 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(33:39) NERR = NERR + 1 ! end if if ( KPRINT >= 2 .OR. NERR /= 0) write (LUN,200) NERR ! return 200 FORMAT(/' * CPPQC - TEST FOR CPPFA, CPPCO, CPPSL AND CPPDI FOUND ' & , I1, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) end subroutine CPRIN (LUN, NUM1, KPRINT, IP, EXACT, RESULT, ABSERR, & !! CPRIN !***SUBSIDIARY !***PURPOSE Subsidiary to CQAG, CQAG, CQAGI, CQAGP, CQAGS, CQAWC, ! CQAWF, CQAWO, CQAWS, and CQNG. !***LIBRARY SLATEC !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! This program is called by the (single precision) Quadpack quick ! check routines for printing out their messages. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 810401 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 910627 Code completely rewritten. (WRB) !***END PROLOGUE CPRIN ! .. Scalar Arguments .. NEVAL, IERV, LIERV) REAL ABSERR, EXACT, RESULT ! .. Array Arguments .. integer IP, KPRINT, LIERV, LUN, NEVAL, NUM1 ! .. Local Scalars .. integer IERV(*) REAL ERROR ! .. Intrinsic Functions .. integer IER, K !***FIRST EXECUTABLE STATEMENT CPRIN INTRINSIC ABS IER = IERV(1) ! ERROR = ABS(EXACT-RESULT) if ( kprint >= 2 ) then if ( IP == 1 ) then ! ! Write PASS message. ! if ( kprint >= 3 ) then write (UNIT=LUN, FMT=9000) NUM1 end if ! ! Write failure messages. ! else write (UNIT=LUN, FMT=9010) NUM1 if ( NUM1 == 0) write (UNIT=LUN, FMT=9020) if ( NUM1 > 0) write (UNIT=LUN, FMT=9030) NUM1 if ( LIERV > 1) write (UNIT=LUN, FMT=9040) (IERV(K), & K=2,LIERV) if ( NUM1 == 6) write (UNIT=LUN, FMT=9050) write (UNIT=LUN, FMT=9060) write (UNIT=LUN, FMT=9070) if ( NUM1 /= 5 ) then write (UNIT=LUN, FMT=9080) EXACT,RESULT,ERROR,ABSERR,IER, & NEVAL else write (LUN,FMT=9090) RESULT,ABSERR,IER,NEVAL end if end if ! end if ! return 9000 FORMAT (' TEST ON IER = ', I2, ' PASSED') 9010 FORMAT (' TEST ON IER = ', I1, ' FAILED.') 9020 FORMAT (' WE MUST HAVE IER = 0, ERROR <= ABSERR AND ABSERR.LE', & '.MAX(EPSABS,EPSREL*ABS(EXACT))') 9030 FORMAT (' WE MUST HAVE IER = ', I1) 9040 FORMAT (' OR IER = ', 8(I1,2X)) 9050 FORMAT (' RESULT, ABSERR, NEVAL AND EVENTUALLY LAST SHOULD BE', & ' ZERO') 9060 FORMAT (' WE HAVE ') 9070 FORMAT (7X, 'EXACT', 11X, 'RESULT', 6X, 'ERROR', 4X, 'ABSERR', & 4X, 'IER NEVAL', /, ' ', 42X, & '(EST.ERR.)(FLAG)(NO F-EVAL)') 9080 FORMAT (' ', 2(E15.7,1X), 2(E9.2,1X), I4, 4X, I6) 9090 FORMAT (5X, 'INFINITY', 4X, E15.7, 11X, E9.2, I5, 4X, I6) end !! CPRPQX !***PURPOSE Quick check for CPZERO and RPZERO. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Kahaner, D. K., (NBS) !***DESCRIPTION ! ! THIS QUICK CHECK ROUTINE IS WRITTEN FOR CPZERO AND RPZERO. ! THE ZEROS OF POLYNOMIAL WITH COEFFICIENTS A(.) ARE STORED ! IN ZK(.). RELERR IS THE RELATIVE ACCURACY REQUIRED FOR ! THEM TO PASS. ! !***ROUTINES CALLED CPZERO, R1MACH, RPZERO !***REVISION HISTORY (YYMMDD) ! 810223 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE CPRPQX subroutine CPRPQX (LUN, KPRINT, IPASS) integer KPRINT,IPASS,LUN integer IDEG,IDEGP1,INFO,I,J,ID REAL A(6),ERR,ERRI,RELERR COMPLEX AC(6),Z(5),ZK(5),W(21) DATA IDEG / 5 / DATA A / 1., -3.7, 7.4, -10.8, 10.8, -6.8 / DATA ZK / (1.7,0.), (1.,1.), (1.,-1.), & (0.,1.4142135623730950488), & !***FIRST EXECUTABLE STATEMENT CPRPQX (0.,-1.4142135623730950488) / ipass = 1 IDEGP1 = IDEG+1 RELERR = SQRT(R1MACH(4)) AC(1:idegp1) = CMPLX(A(1:idegp1),0.) INFO = 0 call CPZERO(IDEG,AC,Z,W(4),INFO,W) if ( INFO == 0) GO TO 15 IPASS=0 if ( INFO == 1 .and. kprint >= 1) WRITE(LUN,630) if ( INFO == 2 .and. kprint >= 1) WRITE(LUN,640) 15 DO 30 J=1,IDEG ERR = ABS(Z(J) - ZK(1)) ID = 1 DO 20 I=2,IDEG ERRI = ABS(Z(J) - ZK(I)) if ( ERRI < ERR) ID = I ERR = min ( ERRI,ERR) 20 continue if ( ABS(Z(J) - ZK(ID))/ABS(ZK(ID)) >= RELERR) ipass = 0 30 continue INFO = 0 call RPZERO(IDEG,A,Z,W(4),INFO,W) if ( INFO == 0) GO TO 35 IPASS=0 if ( INFO == 1 .and. kprint >= 1) WRITE(LUN,650) if ( INFO == 2 .and. kprint >= 1) WRITE(LUN,660) 35 DO 50 J=1,IDEG ERR = ABS(Z(J) - ZK(1)) ID = 1 DO 40 I=2,IDEG ERRI = ABS(Z(J) - ZK(I)) if ( ERRI < ERR) ID = I ERR = min ( ERRI,ERR) 40 continue if ( ABS(Z(J) - ZK(ID))/ABS(ZK(ID)) >= RELERR) ipass = 0 50 continue if ( KPRINT >= 2 .and. ipass /= 0) write (LUN,670) if ( KPRINT >= 1 .and. ipass == 0) write (LUN,680) ! return 630 FORMAT(' CPZERO TEST FAILS: LEADING COEFFICIENT OR DEGREE OF', & ' POLYNOMIAL IS ZERO') 640 FORMAT(' CPZERO TEST FAILS: NON-CONVERGENCE IN 125 ITERATIONS') 650 FORMAT(' RPZERO TEST FAILS: LEADING COEFFICIENT OR DEGREE OF', & ' POLYNOMIAL IS ZERO') 660 FORMAT(' RPZERO TEST FAILS: NON-CONVERGENCE IN 125 ITERATIONS') 670 FORMAT(25H CPRPQX PASSES ALL TESTS.) 680 FORMAT(25H CPRPQX FAILS SOME TESTS.) end !! CPTQC !***PURPOSE Quick check for CPTSL. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS ! OF THE PROPER TYPE FOR THE LINPACK SUBROUTINE BEING TESTED. ! THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF CX ! (THE SOLUTION VECTOR) ARE ENTERED WITH DATA STATEMENTS. ! ! THE COMPUTED VALUES OF X ARE COMPARED TO THE STORED ! PRE-COMPUTED VALUES OF CX. FAILURE OF THE TEST OCCURS WHEN ! AGREEMENT TO 3 SIGNIFICANT DIGITS IS NOT ACHIEVED AND AN ! ERROR MESSAGE IS PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. ! ! NO INPUT ARGUMENTS ARE REQUIRED. ! ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT ! OF ALL FAILURES DETECTED BY CPTQC. ! !***ROUTINES CALLED CPTSL !***REVISION HISTORY (YYMMDD) ! 801024 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if and cleaned up ! FORMATs. (RWC) !***END PROLOGUE CPTQC subroutine CPTQC (LUN, KPRINT, NERR) COMPLEX D(4),E(4),B(4),CX(4),DT(4),ET(4),BT(4) integer N,I,INDX,NERR REAL DELX DATA D/(2.E0,0.E0),(2.E0,0.E0),(3.E0,0.E0),(4.E0,0.E0)/ DATA E/(0.E0,-1.E0),(0.E0,0.E0),(0.E0,-1.E0),(0.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ !***FIRST EXECUTABLE STATEMENT CPTQC DATA CX/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ N = 4 NERR = 0 DT(1:n) = D(1:n) ET(1:n) = E(1:n) BT(1:n) = B(1:n) call CPTSL(N,DT,ET,BT) INDX = 0 DO 20 I=1,N DELX = ABS(REAL(BT(I)-CX(I)))+ABS(AIMAG(BT(I)-CX(I))) if ( DELX > .0001) INDX=INDX+1 ! 20 continue if ( INDX /= 0 ) then write (LUN,201) NERR = NERR + 1 ! end if if ( KPRINT >= 2 .OR. NERR /= 0) write (LUN,200) NERR ! return 200 FORMAT (/' * CPTQC - TEST FOR CPTSL FOUND ', I1, ' ERRORS.'/) 201 FORMAT (/' *** CPTSL FAILURE - ERROR IN SOLUTION') end !! CQAG !***PURPOSE Quick check for QAG. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CQAG-S, CDQAG-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED CPRIN, F1G, F2G, F3G, QAG, R1MACH !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) !***END PROLOGUE CQAG ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CQAG (LUN, KPRINT, IPASS) REAL A,ABSERR,B,R1MACH,EPMACH,EPSABS,EPSREL,ERROR,EXACT1, & EXACT2,EXACT3,F1G,F2G,F3G,PI,RESULT,UFLOW,WORK integer IER,IP,IPASS,IWORK,KEY,KPRINT,LAST,LENW,LIMIT, & NEVAL dimension IERV(2),IWORK(100),WORK(400) EXTERNAL F1G,F2G,F3G DATA PI/0.31415926535897932E+01/ DATA EXACT1/0.1154700538379252E+01/ DATA EXACT2/0.11780972450996172E+00/ !***FIRST EXECUTABLE STATEMENT CQAG DATA EXACT3/0.1855802E+02/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1QAG QUICK CHECK''/)') ipass = 1 LIMIT = 100 LENW = LIMIT*4 EPSABS = 0.0E+00 EPMACH = R1MACH(4) KEY = 6 EPSREL = max ( SQRT(EPMACH),0.1E-07) A = 0.0E+00 B = 0.1E+01 call QAG(F1G,A,B,EPSABS,EPSREL,KEY,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT1-RESULT) if ( IER == 0 .and. ERROR <= ABSERR.AND.ABSERR <= EPSREL*ABS(EXACT1)) & IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 1 ! call CPRIN(LUN,0,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) LIMIT = 1 LENW = LIMIT*4 B = PI*0.2E+01 call QAG(F2G,A,B,EPSABS,EPSREL,KEY,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 2 OR 1 ! call CPRIN(LUN,1,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,1) UFLOW = R1MACH(1) LIMIT = 100 LENW = LIMIT*4 call QAG(F2G,A,B,UFLOW,0.0E+00,KEY,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 if ( IER == 2.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 3 OR 1 ! call CPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,2) B = 0.1E+01 call QAG(F3G,A,B,EPSABS,EPSREL,1,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 if ( IER == 3.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 6 ! call CPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,2) LENW = 1 call QAG(F1G,A,B,EPSABS,EPSREL,KEY,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 6 .and. RESULT == 0.0E+00.AND.ABSERR == 0.0E+00.AND. & NEVAL == 0 .and. LAST == 0) IP = 1 if ( IP == 0) ipass = 0 ! call CPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CQAG FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CQAG PASSED''/)') end if end if return end !! CQAGI !***PURPOSE Quick check for QAGI. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CQAGI-S, CDQAGI-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED CPRIN, QAGI, R1MACH, T0, T1, T2, T3, T4, T5 !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891009 Removed unreferenced variables. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) !***END PROLOGUE CQAGI ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CQAGI (LUN, KPRINT, IPASS) REAL ABSERR,BOUND,R1MACH,EPMACH,EPSABS, & EPSREL,ERROR,EXACT0,EXACT1,EXACT2,EXACT3,EXACT4, & OFLOW,RESULT,T0,T1,T2,T3,T4,T5,UFLOW,WORK integer IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,LUN,NEVAL dimension WORK(800),IWORK(200),IERV(4) EXTERNAL T0,T1,T2,T3,T4,T5 DATA EXACT0/2.0E+00/,EXACT1/0.115470066904E1/ DATA EXACT2/0.909864525656E-02/ DATA EXACT3/0.31415926535897932E+01/ !***FIRST EXECUTABLE STATEMENT CQAGI DATA EXACT4/0.19984914554328673E+04/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1QAGI QUICK CHECK''/)') ipass = 1 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0E+00 EPMACH = R1MACH(4) EPSREL = max ( SQRT(EPMACH),0.1E-07) BOUND = 0.0E+00 INF = 1 call QAGI(T0,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) ERROR = ABS(RESULT-EXACT0) IERV(1) = IER IP = 0 if ( IER == 0 .and. ERROR <= ABSERR.AND.ABSERR <= EPSREL*ABS(EXACT0)) & IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 1 ! call CPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) call QAGI(T1,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, & 1,4,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 2 OR 4 OR 1 ! call CPRIN(LUN,1,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) UFLOW = R1MACH(1) call QAGI(T2,BOUND,INF,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 if ( IER == 2.OR.IER == 4.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 3 OR 4 OR 1 ! call CPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,3) call QAGI(T3,BOUND,INF,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 if ( IER == 3.OR.IER == 4.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 4 OR 3 OR 1 ! call CPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,3) call QAGI(T4,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 3 IERV(3) = 1 IERV(4)=2 IP = 0 if ( IER == 4.OR.IER == 3.OR.IER == 1.OR.IER == 2) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 5 ! call CPRIN(LUN,4,KPRINT,IP,EXACT4,RESULT,ABSERR,NEVAL,IERV,4) OFLOW = R1MACH(2) call QAGI(T5,BOUND,INF,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 5) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 6 ! call CPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) call QAGI(T1,BOUND,INF,EPSABS,0.0E+00,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 6 .and. RESULT == 0.0E+00.AND.ABSERR == 0.0E+00.AND. & NEVAL == 0 .and. LAST == 0) IP = 1 if ( IP == 0) ipass = 0 ! call CPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CQAGI FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CQAGI PASSED''/)') end if end if return end !! CQAGP !***PURPOSE Quick check for QAGP. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CQAGP-S, CDQAGP-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED CPRIN, F1P, F2P, F3P, F4P, QAGP, R1MACH !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) !***END PROLOGUE CQAGP ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CQAGP (LUN, KPRINT, IPASS) REAL A,ABSERR,B,R1MACH,EPMACH,EPSABS,EPSREL,ERROR,EXACT1, & EXACT2,EXACT3,F1P,F2P,F3P,F4P,OFLOW,POINTS,P1,P2,RESULT, & UFLOW,WORK integer IER,IP,IPASS,IWORK,KPRINT,LAST,LENIW,LENW,LIMIT,LUN, & NEVAL,NPTS2 dimension IERV(4),IWORK(205),POINTS(5),WORK(405) EXTERNAL F1P,F2P,F3P,F4P DATA EXACT1/0.4285277667368085E+01/ DATA EXACT2/0.909864525656E-2/ DATA EXACT3/0.31415926535897932E+01/ DATA P1/0.1428571428571428E+00/ !***FIRST EXECUTABLE STATEMENT CQAGP DATA P2/0.6666666666666667E+00/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1QAGP QUICK CHECK''/)') ipass = 1 NPTS2 = 4 LIMIT = 100 LENIW = LIMIT*2+NPTS2 LENW = LIMIT*4+NPTS2 EPSABS = 0.0E+00 EPMACH = R1MACH(4) EPSREL = max ( SQRT(EPMACH),0.1E-07) A = 0.0E+00 B = 0.1E+01 POINTS(1) = P1 POINTS(2) = P2 call QAGP(F1P,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, & IER,LENIW,LENW,LAST,IWORK,WORK) ERROR = ABS(RESULT-EXACT1) IERV(1) = IER IP = 0 if ( IER == 0 .and. ERROR <= EPSREL*ABS(EXACT1)) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 1 ! call CPRIN(LUN,0,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) LENIW = 10 LENW = LENIW*2-NPTS2 call QAGP(F1P,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, & IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 2, 4, 1 OR 3 ! call CPRIN(LUN,1,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) NPTS2 = 3 POINTS(1) = 0.1E+00 LENIW = LIMIT*2+NPTS2 LENW = LIMIT*4+NPTS2 UFLOW = R1MACH(1) A = 0.1E+00 call QAGP(F2P,A,B,NPTS2,POINTS,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL, & IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4) = 3 IP = 0 if ( IER == 2.OR.IER == 4.OR.IER == 1.OR.IER == 3) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 3 OR 4 OR 1 OR 2 ! call CPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,4) NPTS2 = 2 LENIW = LIMIT*2+NPTS2 LENW = LIMIT*4+NPTS2 A = 0.0E+00 B = 0.5E+01 call QAGP(F3P,A,B,NPTS2,POINTS,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL, & IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4)=2 IP = 0 if ( IER == 3.OR.IER == 4.OR.IER == 1.OR.IER == 2) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 5 ! call CPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,4) B = 0.1E+01 call QAGP(F4P,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, & IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 5) IP = 1 if ( IP == 0) ipass = 0 OFLOW = R1MACH(2) ! ! TEST ON IER = 6 ! call CPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) NPTS2 = 5 LENIW = LIMIT*2+NPTS2 LENW = LIMIT*4+NPTS2 POINTS(1) = P1 POINTS(2) = P2 POINTS(3) = 0.3E+01 call QAGP(F1P,A,B,NPTS2,POINTS,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, & IER,LENIW,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 6 .and. RESULT == 0.0E+00.AND.ABSERR == 0.0E+00.AND. & NEVAL == 0 .and. LAST == 0) IP = 1 if ( IP == 0) ipass = 0 ! call CPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CQAGP FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CQAGP PASSED''/)') end if end if return end !! CQAGS !***PURPOSE Quick check for QAGS. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CQAGS-S, CDQAGS-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED CPRIN, F0S, F1S, F2S, F3S, F4S, F5S, QAGS, R1MACH !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) ! 911114 Modified test on IER=4 to allow IER=5. (WRB) !***END PROLOGUE CQAGS ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CQAGS (LUN, KPRINT, IPASS) REAL A,ABSERR,B,R1MACH,EPMACH,EPSABS, & EPSREL,ERROR,EXACT0,EXACT1,EXACT2,EXACT3,EXACT4, & F0S,F1S,F2S,F3S,F4S,F5S,OFLOW,RESULT,UFLOW,WORK integer IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,NEVAL dimension IERV(5),IWORK(200),WORK(800) EXTERNAL F0S,F1S,F2S,F3S,F4S,F5S DATA EXACT0/0.2E+01/ DATA EXACT1/0.115470066904E+01/ DATA EXACT2/0.909864525656E-02/ DATA EXACT3/0.31415926535897932E+01/ !***FIRST EXECUTABLE STATEMENT CQAGS DATA EXACT4/0.19984914554328673E+04/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1QAGS QUICK CHECK''/)') ipass = 1 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0E+00 EPMACH = R1MACH(4) EPSREL = max ( SQRT(EPMACH),0.1E-07) A = 0.0E+00 B = 0.1E+01 call QAGS(F0S,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) ERROR = ABS(RESULT-EXACT0) IERV(1) = IER IP = 0 if ( IER == 0 .and. ERROR <= ABSERR.AND.ABSERR <= EPSREL*ABS(EXACT0)) & IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 1 ! call CPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) call QAGS(F1S,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, & 1,4,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 2 OR 4 OR 1 ! call CPRIN(LUN,1,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) UFLOW = R1MACH(1) A = 0.1E+00 call QAGS(F2S,A,B,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 if ( IER == 2.OR.IER == 4.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 3 OR 4 OR 1 OR 2 ! call CPRIN(LUN,2,KPRINT,IP,EXACT2,RESULT,ABSERR,NEVAL,IERV,3) A = 0.0E+00 B = 0.5E+01 call QAGS(F3S,A,B,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IERV(4) = 2 IP = 0 if ( IER == 3.OR.IER == 4.OR.IER == 1.OR.IER == 2) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 4, OR 5 OR 3 OR 1 OR 0 ! call CPRIN(LUN,3,KPRINT,IP,EXACT3,RESULT,ABSERR,NEVAL,IERV,4) B = 0.1E+01 EPSREL=1.E-4 call QAGS(F4S,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, & ! IER=4 LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 5 IERV(3) = 3 IERV(4) = 1 IERV(5) = 0 IP = 0 if ( IER == 5.OR.IER == 4.OR.IER == 3.OR.IER == 1.OR.IER == 0) & IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 5 ! call CPRIN(LUN,4,KPRINT,IP,EXACT4,RESULT,ABSERR,NEVAL,IERV,5) OFLOW = R1MACH(2) call QAGS(F5S,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 5) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 6 ! call CPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) call QAGS(F1S,A,B,EPSABS,0.0E+00,RESULT,ABSERR,NEVAL,IER, & LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 6 .and. RESULT == 0.0E+00.AND.ABSERR == 0.0E+00.AND. & NEVAL == 0 .and. LAST == 0) IP = 1 if ( IP == 0) ipass = 0 ! call CPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CQAGS FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CQAGS PASSED''/)') end if end if return end !! CQAWC !***PURPOSE Quick check for QAWC. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CQAWC-S, CDQAWC-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED CPRIN, F0C, F1C, QAWC, R1MACH !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) !***END PROLOGUE CQAWC ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CQAWC (LUN, KPRINT, IPASS) REAL A,ABSERR,B,R1MACH,EPMACH,EPSABS, & EPSREL,ERROR,EXACT0,EXACT1,F0C,F1C,C, & RESULT,UFLOW,WORK integer IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,NEVAL dimension WORK(800),IWORK(200),IERV(2) EXTERNAL F0C,F1C DATA EXACT0/-0.6284617285065624E+03/ !***FIRST EXECUTABLE STATEMENT CQAWC DATA EXACT1/0.1855802E+01/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1QAWC QUICK CHECK''/)') ipass = 1 C = 0.5E+00 A = -1.0E+00 B = 1.0E+00 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0E+00 EPMACH = R1MACH(4) EPSREL = max ( SQRT(EPMACH),0.1E-07) call QAWC(F0C,A,B,C,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT0-RESULT) if ( IER == 0 .and. ERROR <= ABSERR.AND.ABSERR <= EPSREL*ABS(EXACT0)) & IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 1 ! call CPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) call QAWC(F0C,A,B,C,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,1,4,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 2 OR 1 ! call CPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) UFLOW = R1MACH(1) call QAWC(F0C,A,B,C,UFLOW,0.0E+00,RESULT,ABSERR, & NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 if ( IER == 2.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 3 OR 1 ! call CPRIN(LUN,2,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,2) call QAWC(F1C,0.0E+00,B,C,UFLOW,0.0E+00,RESULT,ABSERR, & NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 if ( IER == 3.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 6 ! call CPRIN(LUN,3,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,2) EPSABS = 0.0E+00 EPSREL = 0.0E+00 call QAWC(F0C,A,B,C,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 6) IP = 1 if ( IP == 0) ipass = 0 ! call CPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CQAWC FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CQAWC PASSED''/)') end if end if return end !! CQAWF !***PURPOSE Quick check for QAWF. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CQAWF-S, CDQAWF-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED CPRIN, F0F, F1F, QAWF, R1MACH !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) !***END PROLOGUE CQAWF ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CQAWF (LUN, KPRINT, IPASS) REAL A,ABSERR,R1MACH,EPSABS,EPMACH, & ERROR,EXACT0,F0F,F1F,OMEGA,PI,RESULT,UFLOW,WORK integer IER,IP,IPASS,KPRINT,LENW,LIMIT,LIMLST,LST,NEVAL dimension IERV(3),IWORK(450),WORK(1425) EXTERNAL F0F,F1F DATA EXACT0/0.1422552162575912E+01/ !***FIRST EXECUTABLE STATEMENT CQAWF DATA PI/0.31415926535897932E+01/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1QAWF QUICK CHECK''/)') ipass = 1 MAXP1 = 21 LIMLST = 50 LIMIT = 200 LENIW = LIMIT*2+LIMLST LENW = LENIW*2+MAXP1*25 EPMACH = R1MACH(4) EPSABS = max ( SQRT(EPMACH),0.1E-02) A = 0.0E+00 OMEGA = 0.8E+01 INTEGR = 2 call QAWF(F0F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, & IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT0-RESULT) if ( IER == 0 .and. ERROR <= ABSERR.AND.ABSERR <= EPSABS) & IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 1 ! call CPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) LIMLST = 3 LENIW = 403 LENW = LENIW*2+MAXP1*25 call QAWF(F0F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, & IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 3 OR 4 OR 1 ! call CPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) LIMLST = 50 LENIW = LIMIT*2+LIMLST LENW = LENIW*2+MAXP1*25 UFLOW = R1MACH(1) call QAWF(F1F,A,0.0E+00,1,UFLOW,RESULT,ABSERR,NEVAL, & IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 if ( IER == 3.OR.IER == 4.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 6 ! call CPRIN(LUN,3,KPRINT,IP,PI,RESULT,ABSERR,NEVAL,IERV,3) LIMLST = 50 LENIW = 20 call QAWF(F0F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, & IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 6) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 7 ! call CPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) LIMLST = 50 LENIW = 52 LENW = LENIW*2+MAXP1*25 call QAWF(F0F,A,OMEGA,INTEGR,EPSABS,RESULT,ABSERR,NEVAL, & IER,LIMLST,LST,LENIW,MAXP1,LENW,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 7) IP = 1 if ( IP == 0) ipass = 0 ! call CPRIN(LUN,7,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CQAWF FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CQAWF PASSED''/)') end if end if return end !! CQAWO !***PURPOSE Quick check for QAWO. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CQAWO-S, CDQAWO-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED CPRIN, F0O, F1O, F2O, QAWO, R1MACH !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) !***END PROLOGUE CQAWO ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CQAWO (LUN, KPRINT, IPASS) REAL A,ABSERR,B,EPMACH,EPSABS, & EPSREL,ERROR,EXACT0,F0O,F1O,F2O, & OFLOW,OMEGA,PI,RESULT,R1MACH,UFLOW,WORK integer IER,IERV,INTEGR,IP,IPASS,IWORK,KPRINT,LAST,LENW,LUN, & MAXP1,NEVAL dimension WORK(1325),IWORK(400),IERV(4) EXTERNAL F0O,F1O,F2O DATA EXACT0/0.1042872789432789E+05/ !***FIRST EXECUTABLE STATEMENT CQAWO DATA PI/0.31415926535897932E+01/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1QAWO QUICK CHECK''/)') ipass = 1 MAXP1 = 21 LENIW = 400 LENW = LENIW*2+MAXP1*25 EPSABS = 0.0E+00 EPMACH = R1MACH(4) EPSREL = max ( SQRT(EPMACH),0.1E-07) A = 0.0E+00 B = PI OMEGA = 0.1E+01 INTEGR = 2 call QAWO(F0O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, & IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT0-RESULT) if ( IER == 0 .and. ERROR <= ABSERR.AND.ABSERR <= EPSREL*ABS(EXACT0)) & IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 1 ! call CPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) LENIW = 2 LENW = LENIW*2+MAXP1*25 call QAWO(F0O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, & IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 2 OR 4 OR 1 ! call CPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) UFLOW = R1MACH(1) LENIW = 400 LENW = LENIW*2+MAXP1*25 call QAWO(F0O,A,B,OMEGA,INTEGR,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL, & IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 if ( IER == 2.OR.IER == 4.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 3 OR 4 OR 1 ! call CPRIN(LUN,2,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,3) B = 0.5E+01 OMEGA = 0.0E+00 INTEGR = 1 call QAWO(F1O,A,B,OMEGA,INTEGR,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL, & IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 4 IERV(3) = 1 IP = 0 if ( IER == 3.OR.IER == 4.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 5 ! call CPRIN(LUN,3,KPRINT,IP,PI,RESULT,ABSERR,NEVAL,IERV,3) B = 0.1E+01 OFLOW = R1MACH(2) call QAWO(F2O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, & IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 5) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 6 ! call CPRIN(LUN,5,KPRINT,IP,OFLOW,RESULT,ABSERR,NEVAL,IERV,1) INTEGR = 3 call QAWO(F0O,A,B,OMEGA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR,NEVAL, & IER,LENIW,MAXP1,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 6 .and. RESULT == 0.0E+00.AND.ABSERR == 0.0E+00.AND. & NEVAL == 0 .and. LAST == 0) IP = 1 if ( IP == 0) ipass = 0 ! call CPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CQAWO FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CQAWO PASSED''/)') end if end if return end !! CQAWS !***PURPOSE Quick check for QAWS. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CQAWS-S, CDQAWS-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED CPRIN, F0WS, F1WS, QAWS, R1MACH !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) !***END PROLOGUE CQAWS ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC subroutine CQAWS (LUN, KPRINT, IPASS) REAL A,ABSERR,B,R1MACH,EPMACH,EPSABS, & EPSREL,ERROR,EXACT0,EXACT1,F0WS,F1WS,ALFA,BETA, & RESULT,UFLOW,WORK integer IER,IP,IPASS,IWORK,KPRINT,LAST,LENW,LIMIT,NEVAL,INTEGR dimension WORK(800),IWORK(200),IERV(2) EXTERNAL F0WS,F1WS DATA EXACT0/0.5350190569223644E+00/ !***FIRST EXECUTABLE STATEMENT CQAWS DATA EXACT1/0.1998491554328673E+04/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1QAWS QUICK CHECK''/)') ipass = 1 ALFA = -0.5E+00 BETA = -0.5E+00 INTEGR = 1 A = 0.0E+00 B = 0.1E+01 LIMIT = 200 LENW = LIMIT*4 EPSABS = 0.0E+00 EPMACH = R1MACH(4) EPSREL = max ( SQRT(EPMACH),0.1E-07) call QAWS(F0WS,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 ERROR = ABS(EXACT0-RESULT) if ( IER == 0 .and. ERROR <= EPSREL*ABS(EXACT0)) & IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 1 ! call CPRIN(LUN,0,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) call QAWS(F0WS,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,2,8,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 2 OR 1 ! call CPRIN(LUN,1,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) UFLOW = R1MACH(1) call QAWS(F0WS,A,B,ALFA,BETA,INTEGR,UFLOW,0.0E+00,RESULT,ABSERR, & NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 if ( IER == 2.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 3 OR 1 ! call CPRIN(LUN,2,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,2) call QAWS(F1WS,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IERV(2) = 1 IP = 0 if ( IER == 3.OR.IER == 1) IP = 1 if ( IP == 0) ipass = 0 ! ! TEST ON IER = 6 ! call CPRIN(LUN,3,KPRINT,IP,EXACT1,RESULT,ABSERR,NEVAL,IERV,2) INTEGR = 0 call QAWS(F1WS,A,B,ALFA,BETA,INTEGR,EPSABS,EPSREL,RESULT,ABSERR, & NEVAL,IER,LIMIT,LENW,LAST,IWORK,WORK) IERV(1) = IER IP = 0 if ( IER == 6) IP = 1 if ( IP == 0) ipass = 0 ! call CPRIN(LUN,6,KPRINT,IP,EXACT0,RESULT,ABSERR,NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CQAWS FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CQAWS PASSED''/)') end if end if return end !! CQCAI !***SUBSIDIARY !***PURPOSE Quick check for SLATEC subroutines ! CAIRY, CBIRY !***LIBRARY SLATEC !***CATEGORY C10D !***TYPE COMPLEX (CQCAI-C, ZQCAI-Z) !***KEYWORDS QUICK CHECK, CAIRY, CBIRY !***AUTHOR Amos, Don, (SNL) ! Goudy, Sue, (SNL) ! Walton, Lee, (SNL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call CQCAI (LUN, KPRINT, IPASS) ! ! *Arguments: ! ! LUN :IN is the unit number to which output is to be written. ! ! kprint :IN controls the amount of output, as specified in the ! SLATEC Guidelines. ! ! ipass :OUT indicates whether the test passed or failed. ! A value of one is good, indicating no failures. ! ! *Description: ! ! CQCAI is a quick check routine for the complex Airy functions ! generated by subroutines CAIRY and CBIRY. ! ! CQCAI generates Airy functions and their derivatives from CAIRY ! and CBIRY and checks them against the Wronskian evaluation ! in the Z plane. ! !***REFERENCES Abramowitz, M. and Stegun, I. A., Handbook ! of Mathematical Functions, Dover Publications, ! New York, 1964. ! Amos, D. E., A Subroutine Package for Bessel ! Functions of a Complex Argument and Nonnegative ! Order, SAND85-1018, May, 1985. !***ROUTINES CALLED CAIRY, CBIRY, i1mach, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890831 Revised to meet new SLATEC standards ! !***END PROLOGUE CQCAI ! !*Internal Notes: ! Machine constants are defined by functions i1mach and R1MACH. ! ! The parameter MQC can have values 1 (the default) for a faster, ! less definitive test or 2 for a slower, more definitive test. ! !**End ! ! Set test complexity parameter. ! subroutine CQCAI (LUN, KPRINT, IPASS) integer MQC ! ! Declare arguments. ! PARAMETER (MQC=1) ! ! Declare external functions. ! integer LUN, KPRINT, IPASS integer i1mach REAL R1MACH ! ! Declare local variables. ! EXTERNAL i1mach, R1MACH COMPLEX CON1, CON2, CON3, CV, CW, CY, W, Y, Z, ZR REAL AA, AB, ACW, ACY, ALIM, ARG, ARZR, ATOL, AV, A1, A2, CT, & C23, DIG, ELIM, EPS, ER, ERTOL, FILM, FNUL, FPI, HPI, PI, PI3, & R, RL, RM, RPI, RTPI, RZR, R1M4, R1M5, SLAK, SPI, ST, T, TOL, & TPI, TPI3, TS integer I, ICASE, ICL, IERR, IL, IR, IRB, IRSET, IT, ITL, K, KDO, & KEPS, KODE, K1, K2, LFLG, NZ1, NZ2, NZ3, NZ4 ! !***FIRST EXECUTABLE STATEMENT CQCAI dimension KDO(20), KEPS(20), T(20), W(20), Y(20) if ( KPRINT >= 2 ) then write (LUN,99999) 99999 FORMAT (' QUICK CHECK ROUTINE FOR THE AIRY FUNCTIONS FROM ', & 'CAIRY AND CBIRY'/) ! ------------------------------------------------------------------ ! Set parameters related to machine constants. ! TOL is the approximate unit roundoff limited to 1.0E-18. ! ELIM is the approximate exponential over- and underflow limit. ! exp(-ELIM).lt.exp(-ALIM)=exp(-ELIM)/TOL and ! exp(ELIM).gt.exp(ALIM)=exp(ELIM)*TOL are intervals near ! underflow and overflow limits where scaled arithmetic is done. ! RL is the lower boundary of the asymptotic expansion for large Z. ! DIG = number of base 10 digits in TOL = 10**(-DIG). ! FNUL is the lower boundary of the asymptotic series for large FNU. ! ------------------------------------------------------------------ end if R1M4 = R1MACH(4) TOL = max ( R1M4,1.0E-18) ATOL = 100.0E0*TOL AA = -LOG10(R1M4) K1 = i1mach(12) K2 = i1mach(13) R1M5 = R1MACH(5) K = min ( ABS(K1),ABS(K2)) ELIM = 2.303E0*(K*R1M5-3.0E0) AB = AA*2.303E0 ALIM = ELIM + max ( -AB,-41.45E0) DIG = min ( AA,18.0E0) SLAK = 3.0E0+4.0E0*(-LOG10(TOL)-7.0E0)/11.0E0 SLAK = max ( SLAK,3.0E0) ERTOL = TOL*10.0E0**SLAK RL = 1.2E0*DIG + 3.0E0 RM = 0.5E0*(ALIM + ELIM) RM = min ( RM,200.0E0) RM = max ( RM,RL+10.0E0) FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) if ( KPRINT >= 2 ) then write (LUN,99998) 99998 FORMAT (' PARAMETERS'/ & 5X,'TOL ',8X,'ELIM',8X,'ALIM',8X,'RL ',8X,'FNUL',8X,'DIG') write (LUN,99997) TOL, ELIM, ALIM, RL, FNUL, DIG 99997 FORMAT (6E12.4/) ! ------------------------------------------------------------------ ! Generate angles for construction of complex Z to be used in tests. ! ------------------------------------------------------------------ end if FPI = ATAN(1.0E0) HPI = FPI + FPI PI = HPI + HPI TPI = PI + PI RPI = 1.0E0/PI TPI3 = TPI/3.0E0 SPI = PI/6.0E0 PI3 = SPI+SPI RTPI = 1.0E0/TPI A1 = RTPI*COS(SPI) A2 = RTPI*SIN(SPI) CON1 = CMPLX(COS(TPI3),SIN(TPI3)) CON2 = CMPLX(A1,-A2) CON3 = CMPLX(RPI,0.0E0) ! ------------------------------------------------------------------ ! KDO(K), K = 1,IL determines which of the IL angles in -PI to PI ! are used to compute values of Z. ! KDO(K) = 0 means that the index K will be used for one or two ! values of Z, depending on the choice of KEPS(K) ! = 1 means that the index K and the corresponding angle ! will be skipped ! KEPS(K), K = 1,IL determines which of the angles get incremented ! up and down to put values of Z in regions where different ! formulae are used. ! KEPS(K) = 0 means that the angle will be used without change ! = 1 means that the angle will be incremented up and ! down by EPS ! The angles to be used are stored in the T(I) array, I = 1,ITL. ! ------------------------------------------------------------------ C23 = 2.0E0/3.0E0 if ( MQC /= 2 ) then ICL = 1 IL = 5 DO 5 I = 1,IL KDO(I) = 0 KEPS(I) = 0 5 continue else ICL = 2 IL = 7 DO 6 I = 1,IL KDO(I) = 0 KEPS(I) = 0 6 continue KEPS(2) = 1 KEPS(3) = 1 KEPS(5) = 1 KEPS(6) = 1 end if I = 2 EPS = 0.01E0 FILM = IL - 1 T(1) = -PI + EPS DO 30 K = 2,IL if ( KDO(K) == 0 ) then T(I) = PI*(-IL+2*K-1)/FILM if ( KEPS(K) /= 0 ) then TS = T(I) T(I) = TS - EPS I = I + 1 T(I) = TS + EPS end if I = I + 1 end if 30 continue ! ------------------------------------------------------------------ ! Test values of Z in -PI.lt.arg(Z).le.PI near formula boundaries. ! ------------------------------------------------------------------ ITL = I - 1 if ( KPRINT >= 2 ) then write (LUN,99996) 99996 FORMAT (' CHECKS IN THE Z PLANE'/) end if LFLG = 0 ! ------------------------------------------------------------------ ! ICASE = 1 computes wron(AI(Z),BI(Z)) =CON3 ! ICASE = 2 computes wron(AI(Z),AI(Z*CON1))=CON2 ! ------------------------------------------------------------------ DO 180 ICASE = 1,ICL DO 170 KODE = 1,2 DO 160 IRSET = 1,3 IRB = min ( IRSET,2) ! ------- switch (irset) DO 150 IR = IRB,4 GO TO (40, 50, 60), IRSET 40 continue R = 2.0E0*(IR-1)/3.0E0 GO TO 70 50 continue R = (2.0E0*(4-IR)+RL*(IR-1))/3.0E0 GO TO 70 60 continue R = (RL*(4-IR)+RM*(IR-1))/3.0E0 ! ------- end switch 70 continue ! ----------------------------------------------------------------- ! The following values are set before the DO 30 loop: ! C23 = 2/3 ! CON1 = cmplx(cos(2PI/3),sin(2PI/3)) ! CON2 = cmplx(cos(PI/6),-sin(PI/6)/2PI ! CON3 = cmplx(1/PI,0) ! ----------------------------------------------------------------- DO 140 IT = 1,ITL CT = COS(T(IT)) ST = SIN(T(IT)) if ( ABS(CT) < ATOL) CT = 0.0E0 if ( ABS(ST) < ATOL) ST = 0.0E0 Z = CMPLX(R*CT,R*ST) ZR = CMPLX(C23,0.0E0)*Z*SQRT(Z) RZR = REAL(ZR) ! --------- Check for possible underflow or overflow ARZR = ABS(RZR) if ( ARZR /= 0.0E0 ) then ARG = -ARZR - 0.5E0*LOG(ARZR) + 0.226E0 ! ----------- Skip test for this case? ARG = ARG + ARG if ( ARG < (-ELIM)) GO TO 140 end if call CAIRY(Z, 0, KODE, Y(1), NZ1, IERR) call CAIRY(Z, 1, KODE, Y(2), NZ2, IERR) ! ----------- Compare 1/PI with Wronskian of CAIRY(Z) and CBIRY(Z). if ( ICASE == 1 ) then call CBIRY(Z, 0, KODE, W(1), IERR) call CBIRY(Z, 1, KODE, W(2), IERR) ! ------------------------------------------------------------------ ! When KODE = 2, the scaling factor exp(-zeta1-zeta2) is 1.0 for ! -PI.lt.arg(Z).le.PI/3 and exp(-2.0*zeta1) for PI/3.lt.arg(Z) ! .le.PI where zeta1 = zeta2 in this range. This is due to the fact ! that arg(Z*CON1) is taken to be in (-PI,PI) by the principal ! square root. ! ------------------------------------------------------------------ ! ------------- Adjust scaling factor. if ( KODE == 2 ) then CV = CMPLX(ARZR,0.0E0) - ZR CV = EXP(CV) W(1) = W(1)*CV W(2) = W(2)*CV end if CV = CON3 ! ----------- Compare exp(-i*PI/6)/2PI with Wronskian of CAIRY(Z) ! and CAIRY(Z*exp(2i*PI/3)). else CV = Z*CON1 call CAIRY(CV, 0, KODE, W(1), NZ3, IERR) call CAIRY(CV, 1, KODE, W(2), NZ4, IERR) if ( KODE == 2 ) then ! --------------- Adjust scaling factor. if ( T(IT) >= PI3 ) then CV = ZR + ZR CV = EXP(-CV) W(1) = W(1)*CV W(2) = W(2)*CV end if end if W(2) = W(2)*CON1 CV = CON2 ! ------------------------------------------------------------------ ! Error relative to maximum term ! ------------------------------------------------------------------ end if AV = ABS(CV) CW = Y(1)*W(2) CY = Y(2)*W(1) CY = CW - CY - CV ACY = ABS(Y(1))*ABS(W(2)) ACW = ABS(W(1))*ABS(Y(2)) AV = max ( ACW,ACY,AV) ER = ABS(CY)/AV if ( ER >= ERTOL ) then if ( LFLG == 0 ) then if ( KPRINT >= 2 ) then write (LUN,99995) ERTOL 99995 FORMAT (' CASES WHICH VIOLATE THE RELATIVE ERROR', & ' TEST WITH ERTOL = ', E12.4/) write (LUN,99994) 99994 FORMAT (' INPUT TO CAIRY AND ERROR') end if if ( KPRINT >= 3 ) then write (LUN,99993) 99993 FORMAT (' COMPARISON VALUE AND WRONSKIAN') write (LUN,99992) 99992 FORMAT (' RESULTS FROM CAIRY AND/OR CBIRY') write (LUN,99991) 99991 FORMAT (' TEST CASE INDICES'/) end if end if LFLG = 1 if ( KPRINT >= 2 ) then write (LUN,99990) Z, ER 99990 FORMAT (12X,'INPUT: Z=',2E12.4,5X,'ERROR: ER=', & E12.4) end if if ( KPRINT >= 3 ) then write (LUN,99989) CV, CY 99989 FORMAT (' COMPARISON VALUE: CV=',2E12.4/ & 8X,'WRONSKIAN: CY=',2E12.4) write (LUN,99988) NZ1, Y(1), NZ2, Y(2) 99988 FORMAT (10X,'RESULTS: NZ1=',I3,4X,'Y(1)=',2E12.4/ & 20X,'NZ2=',I3,4X,'Y(2)=',2E12.4) if ( ICASE == 1 ) then write (LUN,99987) W(1), W(2) 99987 FORMAT (31X,'W(1)=',2E12.4/31X,'W(2)=',2E12.4) else write (LUN,99986) NZ3, W(1), NZ4, W(2) 99986 FORMAT (20X,'NZ3=',I3,4X,'W(1)=',2E12.4/ & 20X,'NZ4=',I3,4X,'W(2)=',2E12.4) end if write (LUN,99985) IT, IR, IRSET, ICASE 99985 FORMAT (13X,'CASE: IT=',I3,4X,'IR=',I3,4X, & 'IRSET=',I3,4X,'ICASE=',I3,4X/) end if end if 140 continue 150 continue 160 continue 170 continue 180 continue if ( KPRINT >= 2 ) then if ( LFLG == 0 ) then write (LUN,99984) 99984 FORMAT (' QUICK CHECKS OK') else write (LUN,99983) 99983 FORMAT (' ***',5X,'FAILURE(S) FOR CAIRY IN THE Z PLANE') end if end if ipass = 0 if ( LFLG == 0 ) then ipass = 1 end if if ( ipass == 1 .and. KPRINT >= 2 ) then write (LUN,99982) 99982 FORMAT (/' ****** CAIRY PASSED ALL TESTS ******'/) end if if ( ipass == 0 .and. KPRINT >= 1 ) then write (LUN,99981) 99981 FORMAT (/' ****** CAIRY FAILED SOME TESTS ******'/) end if return end !! CQCBH !***SUBSIDIARY !***PURPOSE Quick check for SLATEC subroutine ! CBESH !***LIBRARY SLATEC !***CATEGORY C10A4 !***TYPE COMPLEX (CQCBH-C, ZQCBH-Z) !***KEYWORDS QUICK CHECK, CBESH !***AUTHOR Amos, Don, (SNL) ! Goudy, Sue, (SNL) ! Walton, Lee, (SNL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call CQCBH (LUN, KPRINT, IPASS) ! ! *Arguments: ! ! LUN :IN is the unit number to which output is to be written. ! ! kprint :IN controls the amount of output, as specified in the ! SLATEC Guidelines. ! ! ipass :OUT indicates whether the test passed or failed. ! A value of one is good, indicating no failures. ! ! *Description: ! ! CQCBH is a quick check routine for the complex H Bessel functions ! generated by subroutine CBESH. ! ! CQCBH generates sequences of H Bessel functions for kinds 1 and 2 ! from CBESH and checks them against the Wronskian evaluation ! in the (Z,FNU) space. ! !***REFERENCES Abramowitz, M. and Stegun, I. A., Handbook ! of Mathematical Functions, Dover Publications, ! New York, 1964. ! Amos, D. E., A Subroutine Package for Bessel ! Functions of a Complex Argument and Nonnegative ! Order, SAND85-1018, May, 1985. !***ROUTINES CALLED CBESH, CUOIK, i1mach, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890831 Revised to meet new SLATEC standards ! !***END PROLOGUE CQCBH ! !*Internal Notes: ! Machine constants are defined by functions i1mach and R1MACH. ! ! The parameter MQC can have values 1 (the default) for a faster, ! less definitive test or 2 for a slower, more definitive test. ! !**End ! ! Set test complexity parameter. ! subroutine CQCBH (LUN, KPRINT, IPASS) integer MQC ! ! Declare arguments. ! PARAMETER (MQC=1) ! ! Declare external functions. ! integer LUN, KPRINT, IPASS integer i1mach REAL R1MACH ! ! Declare local variables. ! EXTERNAL i1mach, R1MACH COMPLEX CV, CW, CY, W, Y, Z, ZN REAL AA, AB, ACW, ACY, AER, ALIM, ATOL, AV, AW, AY, AZ, CT, DIG, & ELIM, EPS, ER, ERTOL, FILM, FNU, FNUL, FPI, HPI, PI, R, RFPI, & RL, RM, R1M4, R1M5, R2, SLAK, ST, T, TOL, TS, XNU integer I, ICASE, IERR, IL, IR, IRB, IT, ITL, K, KDO, KEPS, KK, & KODE, K1, K2, LFLG, MFLG, N, NL, NU, NUL, NZ1, NZ2, N1 dimension AER(20), KDO(20), KEPS(20), T(20), W(20), XNU(20), & ! !***FIRST EXECUTABLE STATEMENT CQCBH Y(20) if ( KPRINT >= 2 ) then write (LUN,99999) 99999 FORMAT (' QUICK CHECK ROUTINE FOR THE H BESSEL FUNCTIONS FROM ', & 'CBESH'/) ! ------------------------------------------------------------------ ! Set parameters related to machine constants. ! TOL is the approximate unit roundoff limited to 1.0E-18. ! ELIM is the approximate exponential over- and underflow limit. ! exp(-ELIM).lt.exp(-ALIM)=exp(-ELIM)/TOL and ! exp(ELIM).gt.exp(ALIM)=exp(ELIM)*TOL are intervals near ! underflow and overflow limits where scaled arithmetic is done. ! RL is the lower boundary of the asymptotic expansion for large Z. ! DIG = number of base 10 digits in TOL = 10**(-DIG). ! FNUL is the lower boundary of the asymptotic series for large FNU. ! ------------------------------------------------------------------ end if R1M4 = R1MACH(4) TOL = max ( R1M4,1.0E-18) ATOL = 100.0E0*TOL AA = -LOG10(R1M4) K1 = i1mach(12) K2 = i1mach(13) R1M5 = R1MACH(5) K = min ( ABS(K1),ABS(K2)) ELIM = 2.303E0*(K*R1M5-3.0E0) AB = AA*2.303E0 ALIM = ELIM + max ( -AB,-41.45E0) DIG = min ( AA,18.0E0) FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) RL = 1.2E0*DIG + 3.0E0 SLAK = 3.0E0+4.0E0*(-LOG10(TOL)-7.0E0)/11.0E0 SLAK = max ( SLAK,3.0E0) ERTOL = TOL*10.0E0**SLAK RM = 0.5E0*(ALIM + ELIM) RM = min ( RM,200.0E0) RM = max ( RM,RL+10.0E0) R2 = min ( FNUL,RM) if ( KPRINT >= 2 ) then write (LUN,99998) 99998 FORMAT (' PARAMETERS'/ & 5X,'TOL ',8X,'ELIM',8X,'ALIM',8X,'RL ',8X,'FNUL',8X,'DIG') write (LUN,99997) TOL, ELIM, ALIM, RL, FNUL, DIG 99997 FORMAT (6E12.4/) ! ------------------------------------------------------------------ ! Set other constants needed in the tests. ! ------------------------------------------------------------------ end if FPI = ATAN(1.0E0) HPI = FPI + FPI PI = HPI + HPI RFPI = 1.0E0/FPI ! ------------------------------------------------------------------ ! Generate angles for construction of complex Z to be used in tests. ! ------------------------------------------------------------------ ! KDO(K), K = 1,IL determines which of the IL angles in -PI to PI ! are used to compute values of Z. ! KDO(K) = 0 means that the index K will be used for one or two ! values of Z, depending on the choice of KEPS(K) ! = 1 means that the index K and the corresponding angle ! will be skipped ! KEPS(K), K = 1,IL determines which of the angles get incremented ! up and down to put values of Z in regions where different ! formulae are used. ! KEPS(K) = 0 means that the angle will be used without change ! = 1 means that the angle will be incremented up and ! down by EPS ! The angles to be used are stored in the T(I) array, I = 1,ITL. ! ------------------------------------------------------------------ ZN = CMPLX(0.0E0,-RFPI) if ( MQC /= 2 ) then NL = 2 IL = 5 DO 5 I = 1,IL KEPS(I) = 0 KDO(I) = 0 5 continue NUL = 5 XNU(1) = 0.0E0 XNU(2) = 1.0E0 XNU(3) = 2.0E0 XNU(4) = 0.5E0*FNUL XNU(5) = FNUL + 1.1E0 else NL = 4 IL = 13 DO 6 I = 1,IL KDO(I) = 0 KEPS(I) = 0 6 continue KDO(2) = 1 KDO(6) = 1 KDO(8) = 1 KDO(12) = 1 KEPS(3) = 1 KEPS(4) = 1 KEPS(5) = 1 KEPS(9) = 1 KEPS(10) = 1 KEPS(11) = 1 NUL = 6 XNU(1) = 0.0E0 XNU(2) = 0.6E0 XNU(3) = 1.3E0 XNU(4) = 2.0E0 XNU(5) = 0.5E0*FNUL XNU(6) = FNUL + 1.1E0 end if I = 2 EPS = 0.01E0 FILM = IL - 1 T(1) = -PI + EPS DO 30 K = 2,IL if ( KDO(K) == 0 ) then T(I) = PI*(-IL+2*K-1)/FILM if ( KEPS(K) /= 0 ) then TS = T(I) T(I) = TS - EPS I = I + 1 T(I) = TS + EPS else I = I + 1 end if end if 30 continue ! ------------------------------------------------------------------ ! Test values of Z in -PI.lt.arg(Z).le.PI. ! ------------------------------------------------------------------ ITL = I - 1 if ( KPRINT >= 2 ) then write (LUN,99996) 99996 FORMAT (' CHECKS IN THE (Z,FNU) SPACE'/) end if LFLG = 0 DO 170 KODE = 1,2 DO 160 N = 1,NL N1 = N + 1 DO 150 NU = 1,NUL FNU = XNU(NU) DO 140 ICASE = 1,3 IRB = min ( ICASE,2) ! --------- switch (icase) DO 130 IR = IRB,3 GO TO (50, 60, 70), ICASE 50 continue R = (EPS*(3-IR)+2.0E0*(IR-1))/2.0E0 GO TO 80 60 continue R = (2.0E0*(3-IR)+R2*(IR-1))/2.0E0 GO TO 80 70 continue if ( R2 >= RM) GO TO 140 R = (R2*(3-IR)+RM*(IR-1))/2.0E0 ! --------- end switch 80 continue DO 120 IT = 1,ITL CT = COS(T(IT)) ST = SIN(T(IT)) if ( ABS(CT) < ATOL) CT = 0.0E0 if ( ABS(ST) < ATOL) ST = 0.0E0 Z = CMPLX(R*CT,R*ST) ! ------------- Check for possible overflow condition if ( FNU >= 2.0E0 ) then CV = Z*(0.0E0,1.0E0) call CUOIK(CV, FNU, KODE, 2, N1, W, NZ2, TOL, & ! ------------- Overflow detected? - skip test for this case ELIM, ALIM) if ( NZ2 == (-1)) GO TO 120 CV = -CV call CUOIK(CV, FNU, KODE, 2, N1, W, NZ2, TOL, & ! ------------- Overflow detected? - skip test for this case ELIM, ALIM) if ( NZ2 == (-1)) GO TO 120 ! ----------- No overflow - calculate H1(Z,FNU) and H2(Z,FNU) end if ! ----------- Underflow? - skip test for this case call CBESH(Z, FNU, KODE, 1, N1, Y, NZ1, IERR) if ( NZ1 /= 0) GO TO 120 ! ----------- Underflow? - skip test for this case call CBESH(Z, FNU, KODE, 2, N1, W, NZ2, IERR) ! ------------------------------------------------------------------ ! Compare ZN/Z with the Wronskian of H1(Z,FNU) and H2(Z,FNU). ! ZN = -4i/PI ! ------------------------------------------------------------------ if ( NZ2 /= 0) GO TO 120 CV = ZN/Z MFLG = 0 ! ------------------------------------------------------------------ ! Error relative to maximum term ! ------------------------------------------------------------------ DO 100 I = 1,N AW = ABS(W(I+1)) AY = ABS(Y(I)) AZ = LOG(AW) + LOG(AY) AZ = ABS(AZ) ! --------------- No scaling problem - do error analysis if ( AZ <= ALIM ) then AV = ABS(CV) CW = W(I)*Y(I+1) CY = W(I+1)*Y(I) CY = CW - CY - CV ACY = AW*AY ACW = ABS(W(I))*ABS(Y(I+1)) AV = max ( ACW,ACY,AV) ER = ABS(CY)/AV AER(I) = ER if ( ER > ERTOL ) then MFLG = 1 end if end if 100 continue if ( MFLG /= 0 ) then if ( LFLG == 0 ) then if ( KPRINT >= 2 ) then write (LUN,99995) ERTOL 99995 FORMAT (' CASES WHICH VIOLATE THE RELATIVE ', & 'ERROR TEST WITH ERTOL = ',E12.4/) write (LUN,99994) 99994 FORMAT (' INPUT TO CBESH Z, FNU, KODE, N') end if if ( KPRINT >= 3 ) then write (LUN,99993) 99993 FORMAT (' COMPARE -4i/(PI*Z) WITH WRONSKIAN OF', & ' H1(Z,FNU) AND H2(Z,FNU)') write (LUN,99992) 99992 FORMAT (' RESULTS FROM CBESH FOR FUNCTION H1'/ & ' AND FUNCTION H2') write (LUN,99991) 99991 FORMAT (' TEST CASE INDICES'/) end if end if LFLG = LFLG + 1 if ( KPRINT >= 2 ) then write (LUN,99990) Z, FNU, KODE, N 99990 FORMAT (' INPUT: Z=',2E12.4,4X,'FNU=',E12.4, & 4X,'KODE=',I3,4X,'N=',I3) end if if ( KPRINT >= 3 ) then write (LUN,99989) (AER(K),K=1,N) 99989 FORMAT (' ERROR: AER(K)=',4E12.4) KK = max ( NZ1,NZ2) + 1 KK = min ( N,KK) write (LUN,99988) NZ1, Y(KK), NZ2, W(KK) 99988 FORMAT (' RESULTS: NZ1=',I3,4X,'Y(KK)=',2E12.4/ & 11X,'NZ2=',I3,4X,'W(KK)=',2E12.4) write (LUN,99987) IT, IR, ICASE 99987 FORMAT (' CASE: IT=',I3,4X,'IR=',I3,4X, & 'ICASE=',I3/) end if end if 120 continue 130 continue 140 continue 150 continue 160 continue 170 continue if ( KPRINT >= 2 ) then if ( LFLG == 0 ) then write (LUN,99986) 99986 FORMAT (' QUICK CHECKS OK') else write (LUN,99985) LFLG 99985 FORMAT (' ***',I5,' FAILURE(S) FOR CBESH IN THE (Z,FNU)', & ' PLANE') end if end if ipass = 0 if ( LFLG == 0 ) then ipass = 1 end if if ( ipass == 1 .and. KPRINT >= 2 ) then write (LUN,99984) 99984 FORMAT (/' ****** CBESH PASSED ALL TESTS ******'/) end if if ( ipass == 0 .and. KPRINT >= 1 ) then write (LUN,99983) 99983 FORMAT (/' ****** CBESH FAILED SOME TESTS ******'/) end if return end !! CQCBI !***SUBSIDIARY !***PURPOSE Quick check for SLATEC subroutine ! CBESI !***LIBRARY SLATEC !***CATEGORY C10B4 !***TYPE COMPLEX (CQCBI-C, ZQCBI-Z) !***KEYWORDS QUICK CHECK, CBESI !***AUTHOR Amos, Don, (SNL) ! Goudy, Sue, (SNL) ! Walton, Lee, (SNL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call CQCBI (LUN, KPRINT, IPASS) ! ! *Arguments: ! ! LUN :IN is the unit number to which output is to be written. ! ! kprint :IN controls the amount of output, as specified in the ! SLATEC Guidelines. ! ! ipass :OUT indicates whether the test passed or failed. ! A value of one is good, indicating no failures. ! ! *Description: ! ! CQCBI is a quick check routine for the complex I Bessel function ! generated by subroutine CBESI. ! ! CQCBI generates sequences crossing formula boundaries which ! are started by one formula and terminated in a region where ! another formula applies. The terminated value is checked by ! the formula appropriate to that region. ! !***REFERENCES Abramowitz, M. and Stegun, I. A., Handbook ! of Mathematical Functions, Dover Publications, ! New York, 1964. ! Amos, D. E., A Subroutine Package for Bessel ! Functions of a Complex Argument and Nonnegative ! Order, SAND85-1018, May, 1985. !***ROUTINES CALLED CBESI, CBESK, CWRSK, i1mach, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890831 Revised to meet new SLATEC standards ! !***END PROLOGUE CQCBI ! !*Internal Notes: ! Machine constants are defined by functions i1mach and R1MACH. ! ! The parameter MQC can have values 1 (the default) for a faster, ! less definitive test or 2 for a slower, more definitive test. ! !**End ! ! Set test complexity parameter. ! subroutine CQCBI (LUN, KPRINT, IPASS) integer MQC ! ! Declare arguments. ! PARAMETER (MQC=1) ! ! Declare external functions. ! integer LUN, KPRINT, IPASS integer i1mach REAL R1MACH ! ! Declare local variables. ! EXTERNAL i1mach, R1MACH COMPLEX CK, CONE, CSGN, CW, CY, W, Y, Z, ZN, ZSC, ZT, ZZ REAL AA, AB, AER, ALIM, ARG, ATOL, AW, CARG, CT, DIG, ELIM, EPS, & ER, ERTOL, FILM, FNU, FNUL, GNU, HPI, PI, R, RL, RLT, RM, R1, & R1M4, R1M5, R2, SARG, SLAK, ST, T, TOL, TS, XX, YY integer I, ICASE, IERR, IL, INU, IPRNT, IR, IT, ITL, K, KDO, & KEPS, KK, KODE, K1, K2, LFLG, MFLG, N, NL, NZI, NZK, NZ1, NZ2, & N1 ! !***FIRST EXECUTABLE STATEMENT CQCBI dimension AER(20), CK(2), KDO(20), KEPS(20), T(20), W(20), Y(20) if ( KPRINT >= 2 ) then write (LUN,99999) 99999 FORMAT (' QUICK CHECK ROUTINE FOR THE I BESSEL FUNCTION FROM ', & 'CBESI'/) end if ! ! Set parameters related to machine constants. ! TOL is the approximate unit roundoff limited to 1.0E-18. ! ELIM is the approximate exponential over- and underflow limit. ! exp(-ELIM).lt.exp(-ALIM)=exp(-ELIM)/TOL and ! exp(ELIM).gt.exp(ALIM)=exp(ELIM)*TOL are intervals near ! underflow and overflow limits where scaled arithmetic is done. ! RL is the lower boundary of the asymptotic expansion for large Z. ! DIG = number of base 10 digits in TOL = 10**(-DIG). ! FNUL is the lower boundary of the asymptotic series for large FNU. ! R1M4 = R1MACH(4) TOL = max ( R1M4,1.0E-18) ATOL = 100.0E0*TOL AA = -LOG10(R1M4) K1 = i1mach(12) K2 = i1mach(13) R1M5 = R1MACH(5) K = min ( ABS(K1),ABS(K2)) ELIM = 2.303E0*(K*R1M5-3.0E0) AB = AA*2.303E0 ALIM = ELIM + max ( -AB,-41.45E0) DIG = min ( AA,18.0E0) FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) RL = 1.2E0*DIG + 3.0E0 SLAK = 3.0E0+4.0E0*(-LOG10(TOL)-7.0E0)/11.0E0 SLAK = max ( SLAK,3.0E0) ERTOL = TOL*10.0E0**SLAK RM = 0.5E0*(ALIM + ELIM) RM = min ( RM,200.0E0) RM = max ( RM,RL+10.0E0) R2 = min ( RM,FNUL) R1 = 2.0E0*SQRT(FNUL+1.0E0) if ( KPRINT >= 2 ) then write (LUN,99998) 99998 FORMAT (' PARAMETERS'/ & 5X,'TOL ',8X,'ELIM',8X,'ALIM',8X,'RL ',8X,'FNUL',8X,'DIG') write (LUN,99997) TOL, ELIM, ALIM, RL, FNUL, DIG 99997 FORMAT (1X,6E12.4/) end if ! ------------------------------------------------------------------ ! Set other constants needed in the tests. ! ------------------------------------------------------------------ ZZ = CMPLX(1.0E0/TOL,0.0E0) CONE = CMPLX(1.0E0,0.0E0) HPI = 2.0E0*ATAN(1.0E0) ! ------------------------------------------------------------------ ! Generate angles for construction of complex Z to be used in tests. ! ------------------------------------------------------------------ ! KDO(K), K = 1,IL determines which of the IL angles in -PI to PI ! are used to compute values of Z. ! KDO(K) = 0 means that the index K will be used for one or two ! values of Z, depending on the choice of KEPS(K) ! = 1 means that the index K and the corresponding angle ! will be skipped ! KEPS(K), K = 1,IL determines which of the angles get incremented ! up and down to put values of Z in regions where different ! formulae are used. ! KEPS(K) = 0 means that the angle will be used without change ! = 1 means that the angle will be incremented up and ! down by EPS ! The angles to be used are stored in the T(I) array, I = 1,ITL. ! ------------------------------------------------------------------ PI = HPI + HPI if ( MQC /= 2 ) then NL = 2 IL = 5 DO 5 I = 1,IL KEPS(I) = 0 KDO(I) = 0 5 continue else NL = 4 IL = 13 DO 6 I = 1,IL KDO(I) = 0 KEPS(I) = 0 6 continue KDO(2) = 1 KDO(6) = 1 KDO(8) = 1 KDO(12) = 1 KEPS(3) = 1 KEPS(4) = 1 KEPS(5) = 1 KEPS(9) = 1 KEPS(10) = 1 KEPS(11) = 1 end if I = 2 EPS = 0.01E0 FILM = IL - 1 T(1) = -PI + EPS DO 30 K = 2,IL if ( KDO(K) == 0 ) then T(I) = PI*(-IL+2*K-1)/FILM if ( KEPS(K) /= 0 ) then TS = T(I) T(I) = TS - EPS I = I + 1 T(I) = TS + EPS else I = I + 1 end if end if 30 continue ! ------------------------------------------------------------------ ! Test values of Z in -PI.lt.arg(Z).le.PI near formula boundaries. ! ------------------------------------------------------------------ ITL = I - 1 if ( KPRINT >= 2 ) then write (LUN,99996) 99996 FORMAT (' CHECKS ACROSS FORMULA BOUNDARIES') end if LFLG = 0 DO 220 ICASE = 1,6 DO 210 KODE = 1,2 DO 200 N = 1,NL ! ------------------------------------------------------------------ ! Set values for R = magnitude of Z and for FNU to test computation ! methods for the various regions of the (Z,FNU) plane. ! ------------------------------------------------------------------ N1 = N + 2 ! ------- switch (icase) DO 190 IR = 1,3 GO TO (50, 60, 70, 80, 90, 100), ICASE 50 continue R = (2.0E0*(3-IR)+RL*(IR-1))/2.0E0 GNU = R*R/4.0E0 - 0.2E0 - (N-1) FNU = max ( 0.0E0,GNU) GO TO 110 60 continue R = (RL*(3-IR)+R2*(IR-1))/2.0E0 GNU = SQRT(R+R) - 0.2E0 - (N-1) FNU = max ( 0.0E0,GNU) GO TO 110 70 continue if ( R2 >= RM) GO TO 220 R = (R2*(3-IR)+RM*(IR-1))/2.0E0 GNU = SQRT(R+R) - 0.2E0 - (N-1) FNU = max ( 0.0E0,GNU) GO TO 110 80 continue if ( R1 >= RL) GO TO 220 R = (R1*(3-IR)+RL*(IR-1))/2.0E0 FNU = FNUL - 0.2E0 - (N-1) GO TO 110 90 continue R = (RL*(3-IR)+R2*(IR-1))/2.0E0 FNU = FNUL - 0.2E0 - (N-1) GO TO 110 100 continue if ( R2 >= RM) GO TO 220 R = (R2*(3-IR)+RM*(IR-1))/2.0E0 FNU = FNUL - 0.2E0 - (N-1) ! ------- end switch 110 continue DO 180 IT = 1,ITL CT = COS(T(IT)) ST = SIN(T(IT)) if ( ABS(CT) < ATOL) CT = 0.0E0 if ( ABS(ST) < ATOL) ST = 0.0E0 Z = CMPLX(R*CT,R*ST) XX = REAL(Z) YY = AIMAG(Z) call CBESI(Z, FNU, KODE, N1, Y, NZ1, IERR) ! ------------------------------------------------------------------ ! Compare values from CBESI with values from CWRSK, an alternative ! method for calculating the complex Bessel I function. ! ------------------------------------------------------------------ if ( NZ1 /= 0) GO TO 180 ZN = Z if ( XX >= 0.0E0 ) then call CWRSK(ZN, FNU, KODE, N, W, NZ2, CK, TOL, ELIM, & ALIM) if ( NZ2 /= 0) GO TO 180 else ZN = -Z INU = INT(FNU) ARG = (FNU-INU)*PI if ( YY < 0.0E0) ARG = -ARG CARG = COS(ARG) SARG = SIN(ARG) CSGN = CMPLX(CARG,SARG) if ( MOD(INU,2) == 1) CSGN = -CSGN call CWRSK(ZN, FNU, KODE, N, W, NZ2, CK, TOL, ELIM, & ALIM) if ( NZ2 /= 0) GO TO 180 DO 130 I = 1,N W(I) = W(I)*CSGN CSGN = -CSGN 130 continue end if MFLG = 0 DO 160 I = 1,N AB = FNU + I - 1 AA = max ( 2.0E0,AB) ZT = W(I) if ( CABS(ZT) > 1.0E0 ) then ZSC = CMPLX(TOL,0.0E0) else ! ------------- ZZ = CMPLX(1.0/TOL,0.0) ZSC = ZZ end if CW = W(I)*ZSC CY = Y(I)*ZSC ER = CABS(CY-CW) AW = CABS(CW) if ( AW /= 0.0E0 ) then if ( XX == 0.0E0 ) then if ( ABS(YY) < AA ) then ER=ER/AW else ER=CABS(W(I)-Y(I)) end if else ER=ER/AW end if else ER=CABS(Y(I)) end if AER(I) = ER if ( ER >= ERTOL) MFLG = 1 ! ------------------------------------------------------------------ ! Write failure reports for KPRINT.ge.2 and KPRINT.ge.3 ! ------------------------------------------------------------------ 160 continue if ( MFLG /= 0 ) then if ( LFLG == 0 ) then if ( KPRINT >= 2 ) then write (LUN,99995) ERTOL 99995 FORMAT (/' CASES WHICH UNDERFLOW OR VIOLATE THE ', & 'RELATIVE ERROR TEST'/' WITH ERTOL = ', E12.4/) write (LUN,99994) 99994 FORMAT (' INPUT TO CBESI Z, FNU, KODE, N') end if if ( KPRINT >= 3 ) then write (LUN,99993) 99993 FORMAT (' ERROR TEST ON RESULTS FROM CBESI AND ', & 'CWRSK AER(K)') write (LUN,99992) 99992 FORMAT (' RESULTS FROM CBESI NZ1, Y(KK)'/, & ' RESULTS FROM CWRSK NZ2, W(KK)') write (LUN,99991) 99991 FORMAT (' TEST CASE INDICES IT, IR, ICASE'/) end if end if LFLG = LFLG + 1 if ( KPRINT >= 2 ) then write (LUN,99990) Z, FNU, KODE, N 99990 FORMAT (' INPUT: Z=',2E12.4,4X,'FNU=',E12.4,4X, & 'KODE=',I3,4X,'N=',I3) end if if ( KPRINT >= 3 ) then write (LUN,99989) (AER(K),K=1,N) 99989 FORMAT (' ERROR: AER(K)=',4E12.4) KK = max ( NZ1,NZ2) + 1 KK = min ( N,KK) write (LUN,99988) NZ1, Y(KK), NZ2, W(KK) 99988 FORMAT (' RESULTS: NZ1=',I3,4X,'Y(KK)=',2E12.4, & /11X,'NZ2=',I3,4X,'W(KK)=',2E12.4) write (LUN,99987) IT, IR, ICASE 99987 FORMAT (' CASE: IT=',I3,4X,'IR=',I3,4X, & 'ICASE=',I3/) end if end if 180 continue 190 continue 200 continue 210 continue 220 continue if ( KPRINT >= 2 ) then if ( LFLG == 0 ) then write (LUN,99986) 99986 FORMAT (' QUICK CHECKS OK') else write (LUN,99985) LFLG 99985 FORMAT(' ***',I5,' FAILURE(S) FOR CBESI CHECKS NEAR FORMULA ', & 'BOUNDARIES') end if ! ! end if IPRNT = 0 ! ------------------------------------------------------------------ ! Checks near underflow limits on series(I=1) and uniform ! asymptotic expansion(I=2) ! Compare 1/Z with I(Z,FNU)*K(Z,FNU+1) + I(Z,FNU+1)*K(Z,FNU) and ! report cases for which the relative error is greater than ERTOL. ! ------------------------------------------------------------------ if ( MQC == 1) GO TO 900 if ( KPRINT >= 2 ) then write (LUN,99984) 99984 FORMAT (/' CHECKS NEAR UNDERFLOW AND OVERFLOW LIMITS'/) end if Z = (1.4E0,1.4E0) KODE = 1 N = 20 DO 280 I = 1,2 ! ------------------------------------------------------------------ ! Adjust FNU by repeating until 0.lt.NZI.lt.10 ! ------------------------------------------------------------------ FNU = 10.2E0 230 continue call CBESI(Z, FNU, KODE, N, Y, NZI, IERR) if ( NZI /= 0 ) then if ( NZI >= 10 ) then FNU = FNU - 1.0E0 GO TO 230 end if else FNU = FNU + 5.0E0 GO TO 230 ! - End repeat end if call CBESK(Z, FNU, KODE, 2, W, NZK, IERR) ZT = CONE/Z CY = W(1)*Y(2) CW = W(2)*Y(1) CW = CW + CY - ZT ! ------------------------------------------------------------------ ! Write failure reports for KPRINT.ge.2 and KPRINT.ge.3 ! ------------------------------------------------------------------ ER = ABS(CW)/ABS(ZT) if ( ER >= ERTOL ) then if ( IPRNT == 0 ) then if ( KPRINT >= 2 ) then write (LUN,99983) 99983 FORMAT (' INPUT TO CBESI Z, FNU, KODE, N') end if if ( KPRINT >= 3 ) then write (LUN,99982) 99982 FORMAT (' COMPARE 1/Z WITH WRONSKIAN(CBESI(Z,FNU),', & 'CBESK(Z,FNU))'/) end if end if IPRNT = 1 if ( KPRINT >= 2 ) then write (LUN,99981) Z, FNU, KODE, N 99981 FORMAT (' INPUT: Z=',2E12.4,3X,'FNU=',E12.4,3X,'KODE=',I3, & 3X,'N=',I3) end if if ( KPRINT >= 3 ) then write (LUN,99980) ZT, CW+CY 99980 FORMAT (' RESULTS:',15X,'1/Z=',2E12.4/ & 10X,'WRON(CBESI,CBESK)=',2E12.4) write (LUN,99979) ER 99979 FORMAT (' RELATIVE ERROR:',9X,'ER=',E12.4/) end if end if RLT = RL + RL Z = CMPLX(RLT,0.0E0) ! ------------------------------------------------------------------ ! Check near overflow limits ! Compare 1/Z with I(Z,FNU)*K(Z,FNU+1) + I(Z,FNU+1)*K(Z,FNU) and ! report cases for which the relative error is greater than ERTOL. ! ------------------------------------------------------------------ 280 continue Z = CMPLX(ELIM,0.0E0) ! ------------------------------------------------------------------ ! Adjust FNU by repeating until NZK.lt.10 ! N = 20 set before DO 280 loop ! ------------------------------------------------------------------ FNU = 0.0E0 290 continue call CBESK(Z, FNU, KODE, N, Y, NZK, IERR) if ( NZK >= 10 ) then if ( NZK == N ) then FNU = FNU + 3.0E0 else FNU = FNU + 2.0E0 end if GO TO 290 !---- End repeat end if GNU = FNU + (N-2) call CBESI(Z, GNU, KODE, 2, W, NZI, IERR) ZT = CONE/Z CY = Y(N-1)*W(2) CW = Y(N)*W(1) CW = CW + CY - ZT ER = ABS(CW)/ABS(ZT) if ( ER >= ERTOL ) then if ( IPRNT == 0 ) then if ( KPRINT >= 2 ) then write (LUN,99983) end if if ( KPRINT >= 3 ) then write (LUN,99982) end if end if IPRNT = 1 if ( KPRINT >= 2 ) then write (LUN,99981) Z, FNU, KODE, N end if if ( KPRINT >= 3 ) then write (LUN,99980) ZT, CW+CY write (LUN,99979) ER end if end if if ( KPRINT >= 2 ) then if ( IPRNT == 0 ) then ! 99986 FORMAT (' QUICK CHECKS OK') write (LUN,99986) else write (LUN,99978) 99978 FORMAT (' ***',5X,'FAILURE(S) FOR CBESI NEAR UNDERFLOW AND ', & 'OVERFLOW LIMITS') end if end if 900 continue ipass = 0 if ( IPRNT == 0 .and. LFLG == 0 ) then ipass = 1 end if if ( ipass == 1 .and. KPRINT >= 2 ) then write (LUN,99977) 99977 FORMAT (/' ****** CBESI PASSED ALL TESTS ******'/) end if if ( ipass == 0 .and. KPRINT >= 1 ) then write (LUN,99976) 99976 FORMAT (/' ****** CBESI FAILED SOME TESTS ******'/) end if return end !! CQCBJ !***SUBSIDIARY !***PURPOSE Quick check for SLATEC subroutine ! CBESJ !***LIBRARY SLATEC !***CATEGORY C10A4 !***TYPE COMPLEX (CQCBJ-C, ZQCBJ-Z) !***KEYWORDS QUICK CHECK, CBESJ !***AUTHOR Amos, Don, (SNL) ! Goudy, Sue, (SNL) ! Walton, Lee, (SNL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call CQCBJ (LUN, KPRINT, IPASS) ! ! *Arguments: ! ! LUN :IN is the unit number to which output is to be written. ! ! kprint :IN controls the amount of output, as specified in the ! SLATEC Guidelines. ! ! ipass :OUT indicates whether the test passed or failed. ! A value of one is good, indicating no failures. ! ! *Description: ! ! CQCBJ is a quick check routine for the complex J Bessel function ! generated by subroutine CBESJ. ! ! CQCBJ generates sequences of J Bessel functions from CBESJ ! and checks them against the evaluation from the formula ! ! J(FNU,Z) = 0.5*( H(1,FNU,Z) + H(2,FNU,Z) ) ! ! where -PI.lt.arg(Z).le.PI for abs(Z).ge.FNU. ! ! For abs(Z).lt.FNU, the first N members of a sequence of length ! N+16 are checked against a corresponding N member sequence where ! both sequences are generated by CBESJ beginning at order FNU. ! !***REFERENCES Abramowitz, M. and Stegun, I. A., Handbook ! of Mathematical Functions, Dover Publications, ! New York, 1964. ! Amos, D. E., A Subroutine Package for Bessel ! Functions of a Complex Argument and Nonnegative ! Order, SAND85-1018, May, 1985. !***ROUTINES CALLED CBESH, CBESJ, i1mach, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890831 Revised to meet new SLATEC standards ! !***END PROLOGUE CQCBJ ! !*Internal Notes: ! Machine constants are defined by functions i1mach and R1MACH. ! ! The parameter MQC can have values 1 (the default) for a faster, ! less definitive test or 2 for a slower, more definitive test. ! !**End ! ! Set test complexity parameter. ! subroutine CQCBJ (LUN, KPRINT, IPASS) integer MQC ! ! Declare arguments. ! PARAMETER (MQC=1) ! ! Declare external functions. ! integer LUN, KPRINT, IPASS integer i1mach REAL R1MACH ! ! Declare local variables. ! EXTERNAL i1mach, R1MACH COMPLEX CHALF, COE1, COE2, CW, V, W, Y, Z REAL AA, AB, AER, ALIM, ATOL, AV, CC, CT, DD, DIG, ELIM, EPS, ER, & ERTOL, FILM, FNU, FNUL, GNU, HPI, PI, R, RL, RM, R1M4, R1M5, & R2, SLAK, ST, T, TOL, TS, XNU, XX, YY integer I, ICASE, IERR, IL, IR, IRB, IT, ITL, K, KDO, KEPS, KK, & KODE, K1, K2, LFLG, M, MFLG, N, NL, NU, NUL, NZ, NZ1, NZ2 dimension AER(20), KDO(20), KEPS(20), T(20), V(20), W(20), & ! !***FIRST EXECUTABLE STATEMENT CQCBJ XNU(20), Y(20) if ( KPRINT >= 2 ) then write (LUN,99999) 99999 FORMAT (' QUICK CHECK ROUTINE FOR THE J BESSEL FUNCTION FROM ', & 'CBESJ'/) ! ------------------------------------------------------------------ ! Set parameters related to machine constants. ! TOL is the approximate unit roundoff limited to 1.0E-18. ! ELIM is the approximate exponential over- and underflow limit. ! exp(-ELIM).lt.exp(-ALIM)=exp(-ELIM)/TOL and ! exp(ELIM).gt.exp(ALIM)=exp(ELIM)*TOL are intervals near ! underflow and overflow limits where scaled arithmetic is done. ! RL is the lower boundary of the asymptotic expansion for large Z. ! DIG = number of base 10 digits in TOL = 10**(-DIG). ! FNUL is the lower boundary of the asymptotic series for large FNU. ! ------------------------------------------------------------------ end if R1M4 = R1MACH(4) TOL = max ( R1M4,1.0E-18) ATOL = 100.0E0*TOL AA = -LOG10(R1M4) K1 = i1mach(12) K2 = i1mach(13) R1M5 = R1MACH(5) K = min ( ABS(K1),ABS(K2)) ELIM = 2.303E0*(K*R1M5-3.0E0) AB = AA*2.303E0 ALIM = ELIM + max ( -AB,-41.45E0) DIG = min ( AA,18.0E0) FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) RL = 1.2E0*DIG + 3.0E0 SLAK = 3.0E0+4.0E0*(-LOG10(TOL)-7.0E0)/11.0E0 SLAK = max ( SLAK,3.0E0) ERTOL = TOL*10.0E0**SLAK RM = 0.5E0*(ALIM + ELIM) RM = min ( RM,200.0E0) RM = max ( RM,RL+10.0E0) R2 = min ( RM,FNUL) if ( KPRINT >= 2 ) then write (LUN,99998) 99998 FORMAT (' PARAMETERS'/ & 5X,'TOL ',8X,'ELIM',8X,'ALIM',8X,'RL ',8X,'FNUL',8X,'DIG') write (LUN,99997) TOL, ELIM, ALIM, RL, FNUL, DIG 99997 FORMAT (1X,6E12.4/) ! ------------------------------------------------------------------ ! Set other constants needed in the tests. ! ------------------------------------------------------------------ end if CHALF = (0.5E0,0.0E0) HPI = 2.0E0*ATAN(1.0E0) ! ------------------------------------------------------------------ ! Generate angles for construction of complex Z to be used in tests. ! ------------------------------------------------------------------ ! KDO(K), K = 1,IL determines which of the IL angles in -PI to PI ! are used to compute values of Z. ! KDO(K) = 0 means that the index K will be used for one or two ! values of Z, depending on the choice of KEPS(K) ! = 1 means that the index K and the corresponding angle ! will be skipped ! KEPS(K), K = 1,IL determines which of the angles get incremented ! up and down to put values of Z in regions where different ! formulae are used. ! KEPS(K) = 0 means that the angle will be used without change ! = 1 means that the angle will be incremented up and ! down by EPS ! The angles to be used are stored in the T(I) array, I = 1,ITL. ! ------------------------------------------------------------------ PI = HPI + HPI if ( MQC /= 2 ) then NL = 2 IL = 5 DO 5 I = 1,IL KEPS(I) = 0 KDO(I) = 0 5 continue NUL = 5 XNU(1) = 0.0E0 XNU(2) = 1.0E0 XNU(3) = 2.0E0 XNU(4) = 0.5E0*FNUL XNU(5) = FNUL + 1.1E0 else NL = 4 IL = 13 DO 6 I = 1,IL KDO(I) = 0 KEPS(I) = 0 6 continue KDO(2) = 1 KDO(6) = 1 KDO(8) = 1 KDO(12) = 1 KEPS(3) = 1 KEPS(4) = 1 KEPS(5) = 1 KEPS(9) = 1 KEPS(10) = 1 KEPS(11) = 1 NUL = 6 XNU(1) = 0.0E0 XNU(2) = 0.6E0 XNU(3) = 1.3E0 XNU(4) = 2.0E0 XNU(5) = 0.5E0*FNUL XNU(6) = FNUL + 1.1E0 end if I = 2 EPS = 0.01E0 FILM = IL - 1 T(1) = -PI + EPS DO 30 K = 2,IL if ( KDO(K) == 0 ) then T(I) = PI*(-IL+2*K-1)/FILM if ( KEPS(K) == 0 ) then TS = T(I) T(I) = TS - EPS I = I + 1 T(I) = TS + EPS else I = I + 1 end if end if 30 continue ! ------------------------------------------------------------------ ! Test values of Z in -PI.lt.arg(Z).le.PI. ! ------------------------------------------------------------------ ITL = I - 1 if ( KPRINT >= 2 ) then write (LUN,99996) 99996 FORMAT (' CHECKS IN THE (Z,FNU) SPACE'/) end if LFLG = 0 DO 260 KODE = 1,2 DO 250 N = 1,NL DO 240 NU = 1,NUL FNU = XNU(NU) DO 230 ICASE = 1,3 IRB = min ( 2,ICASE) ! --------- switch (icase) DO 220 IR = IRB,4 GO TO (50, 60, 70), ICASE 50 continue R = (EPS*(4-IR)+2.0E0*(IR-1))/3.0E0 GO TO 80 60 continue R = (2.0E0*(4-IR)+R2*(IR-1))/3.0E0 GO TO 80 70 continue if ( R2 >= RM) GO TO 230 R = (R2*(4-IR)+RM*(IR-1))/3.0E0 ! --------- end switch 80 continue GNU = FNU + (N-1) DO 210 IT = 1,ITL CT = COS(T(IT)) ST = SIN(T(IT)) if ( ABS(CT) < ATOL) CT = 0.0E0 if ( ABS(ST) < ATOL) ST = 0.0E0 Z = CMPLX(R*CT,R*ST) XX = REAL(Z) YY = AIMAG(Z) ! ------------- Cases for abs(Z).ge.FNU+N-1 if ( R >= GNU ) then ! ------------- Underflow - skip test for this case. call CBESJ(Z, FNU, KODE, N, V, NZ, IERR) if ( NZ /= 0) GO TO 210 call CBESH(Z, FNU, KODE, 1, N, W, NZ1, IERR) call CBESH(Z, FNU, KODE, 2, N, Y, NZ2, IERR) ! --------------- Adjust scaling of H functions. if ( KODE == 2 ) then CC = -YY - ABS(YY) if ( CC > (-ALIM) ) then CW = CMPLX(CC,XX) COE1 = EXP(CW) else COE1 = CMPLX(0.0E0,0.0E0) end if DD = YY - ABS(YY) if ( DD > (-ALIM) ) then CW = CMPLX(DD,-XX) COE2 = EXP(CW) else COE2 = CMPLX(0.0E0,0.0E0) end if DO 130 KK = 1,N Y(KK) = Y(KK)*COE2 W(KK) = W(KK)*COE1 130 continue end if ! ------------- Cases for abs(Z).lt.FNU+N-1 else M = N + 16 ! ------------- Underflow at end of sequence - skip test call CBESJ(Z, FNU, KODE, M, V, NZ, IERR) if ( NZ > 10) GO TO 210 call CBESJ(Z, FNU, KODE, N, W, NZ, IERR) DO 150 KK = 1,N Y(KK) = W(KK) 150 continue ! ------------------------------------------------------------------ ! If abs(Z).ge.FNU+N-1 then the error test compares J(Z ERTOL) MFLG = 1 190 continue if ( MFLG /= 0 ) then if ( LFLG == 0 ) then if ( KPRINT >= 2 ) then write (LUN,99995) ERTOL 99995 FORMAT (' CASES WHICH VIOLATE THE RELATIVE ', & 'ERROR TEST WITH ERTOL=', E12.4/) write (LUN,99994) 99994 FORMAT (' INPUT TO CBESJ Z, FNU, KODE, N') end if if ( KPRINT >= 3 ) then if ( R >= GNU ) then write (LUN,99993) 99993 FORMAT (' COMPARE WITH AVERAGE OF H1 AND H2 ', & 'FUNCTIONS FOR THE SAME INPUT') write (LUN,99992) 99992 FORMAT (' RESULTS FROM CBESJ NZ, V(KK)') write (LUN,99991) 99991 FORMAT (' RESULTS FROM CBESH NZ1, W(KK)') write (LUN,99990) 99990 FORMAT (' RESULTS FROM CBESH NZ2, Y(KK)') else write (LUN,99989) 99989 FORMAT (' RESULTS FROM CBESJ NZ, W(KK)') end if write (LUN,99988) 99988 FORMAT (' TEST CASE INDICES IR, IT, ICASE'/) end if end if LFLG = LFLG + 1 if ( KPRINT >= 2 ) then write (LUN,99987) Z, FNU, KODE, N 99987 FORMAT (' INPUT: Z=',2E12.4,3X,'FNU=',E12.4, & 3X,'KODE=',I3,3X,'N=',I3) end if if ( KPRINT >= 3 ) then write (LUN,99986) (AER(K),K=1,N) 99986 FORMAT (' ERROR: AER(K)=',4E12.4) if ( R >= GNU ) then KK = max ( NZ1,NZ2) + 1 KK = min ( N,KK) write (LUN,99985) NZ, V(KK) 99985 FORMAT (' RESULTS: NZ=',I3,3X,'V(KK)=',2E12.4) write (LUN,99984) NZ1, W(KK) 99984 FORMAT (' RESULTS: NZ1=',I3,3X,'W(KK)=',2E12.4) write (LUN,99983) NZ2, Y(KK) 99983 FORMAT (' RESULTS: NZ2=',I3,3X,'Y(KK)=',2E12.4) else KK = N - NZ write (LUN,99982) NZ, W(KK) 99982 FORMAT (' RESULTS: NZ=',I3,3X,'W(KK)=',2E12.4) end if write (LUN,99981) IR, IT, ICASE 99981 FORMAT (' CASE: IR=',I3,3X,'IT=',I3,3X, & 'ICASE=',I3/) end if end if 210 continue 220 continue 230 continue 240 continue 250 continue 260 continue if ( KPRINT >= 2 ) then if ( LFLG == 0 ) then write (LUN,99980) 99980 FORMAT (' QUICK CHECKS OK') else write (LUN,99979) LFLG 99979 FORMAT (' ***',I5,' FAILURE(S) FOR CBESJ IN THE (Z,FNU)', & ' PLANE') end if end if IPASS=0 if ( LFLG == 0 ) then IPASS=1 end if if ( ipass == 1 .and. KPRINT >= 2 ) then write (LUN,99978) 99978 FORMAT (/' ****** CBESJ PASSED ALL TESTS ******'/) end if if ( ipass == 0 .and. KPRINT >= 1 ) then write (LUN,99977) 99977 FORMAT (/' ****** CBESJ FAILED SOME TESTS ******'/) end if return end !! CQCBK !***SUBSIDIARY !***PURPOSE Quick check for SLATEC subroutine ! CBESK !***LIBRARY SLATEC !***CATEGORY C10B4 !***TYPE COMPLEX (CQCBK-C, ZQCBK-Z) !***KEYWORDS QUICK CHECK, CBESK !***AUTHOR Amos, Don, (SNL) ! Goudy, Sue, (SNL) ! Walton, Lee, (SNL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call CQCBK (LUN, KPRINT, IPASS) ! ! *Arguments: ! ! LUN :IN is the unit number to which output is to be written. ! ! kprint :IN controls the amount of output, as specified in the ! SLATEC Guidelines. ! ! ipass :OUT indicates whether the test passed or failed. ! A value of one is good, indicating no failures. ! ! *Description: ! ! CQCBK is a quick check routine for the complex K Bessel function ! generated by subroutine CBESK. ! ! CQCBK generates sequences of I and K Bessel functions from ! CBESI and CBESK and checks them against the Wronskian evaluation ! in the (Z,FNU) space. ! !***REFERENCES Abramowitz, M. and Stegun, I. A., Handbook ! of Mathematical Functions, Dover Publications, ! New York, 1964. ! Amos, D. E., A Subroutine Package for Bessel ! Functions of a Complex Argument and Nonnegative ! Order, SAND85-1018, May, 1985. !***ROUTINES CALLED CBESI, CBESK, i1mach, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890831 Revised to meet new SLATEC standard ! !***END PROLOGUE CQCBK ! !*Internal Notes: ! Machine constants are defined by functions i1mach and R1MACH. ! ! The parameter MQC can have values 1 (the default) for a faster, ! less definitive test or 2 for a slower, more definitive test. ! !**End ! ! Set test complexity parameter. ! subroutine CQCBK (LUN, KPRINT, IPASS) integer MQC ! ! Declare arguments. ! PARAMETER (MQC=1) ! ! Declare external functions. ! integer LUN, KPRINT, IPASS integer i1mach REAL R1MACH ! ! Declare local variables. ! EXTERNAL i1mach, R1MACH COMPLEX CONE, CSGN, CV, CW, CY, W, Y, Z, ZN REAL AA, AB, AER, ALIM, ARG, ATOL, AXX, CT, DIG, ELIM, EPS, ER, & ERTOL, FFNU, FILM, FNU, FNUL, HPI, PI, R, RL, RM, R1M4, R1M5, & R2, SLAK, ST, T, TOL, TS, XNU, XX integer I, ICASE, IERR, IFNU, IL, IR, IRB, IT, ITL, K, KDO, KEPS, & KK, KODE, K1, K2, LFLG, MFLG, N, NL, NU, NUL, NZ1, NZ2, N1 dimension AER(20), KDO(20), KEPS(20), T(20), W(20), XNU(20), & ! !***FIRST EXECUTABLE STATEMENT CQCBK Y(20) if ( KPRINT >= 2 ) then write (LUN,99999) 99999 FORMAT (' QUICK CHECK ROUTINE FOR THE K BESSEL FUNCTION FROM ', & 'CBESK'/) ! ------------------------------------------------------------------ ! Set parameters related to machine constants. ! TOL is the approximate unit roundoff limited to 1.0E-18. ! ELIM is the approximate exponential over- and underflow limit. ! exp(-ELIM).lt.exp(-ALIM)=exp(-ELIM)/TOL and ! exp(ELIM).gt.exp(ALIM)=exp(ELIM)*TOL are intervals near ! underflow and overflow limits where scaled arithmetic is done. ! RL is the lower boundary of the asymptotic expansion for large Z. ! DIG = number of base 10 digits in TOL = 10**(-DIG). ! FNUL is the lower boundary of the asymptotic series for large FNU. ! ------------------------------------------------------------------ end if R1M4 = R1MACH(4) TOL = max ( R1M4,1.0E-18) ATOL = 100.0E0*TOL AA = -LOG10(R1M4) K1 = i1mach(12) K2 = i1mach(13) R1M5 = R1MACH(5) K = min ( ABS(K1),ABS(K2)) ELIM = 2.303E0*(K*R1M5-3.0E0) AB = AA*2.303E0 ALIM = ELIM + max ( -AB,-41.45E0) DIG = min ( AA,18.0E0) FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) RL = 1.2E0*DIG + 3.0E0 SLAK = 3.0E0+4.0E0*(-LOG10(TOL)-7.0E0)/11.0E0 SLAK = max ( SLAK,3.0E0) ERTOL = TOL*10.0E0**SLAK RM = 0.5E0*(ALIM + ELIM) RM = min ( RM,200.0E0) RM = max ( RM,RL+10.0E0) R2 = min ( RM,FNUL) if ( KPRINT >= 2 ) then write (LUN,99998) 99998 FORMAT (' PARAMETERS'/ & 5X,'TOL ',8X,'ELIM',8X,'ALIM',8X,'RL ',8X,'FNUL',8X,'DIG') write (LUN,99997) TOL, ELIM, ALIM, RL, FNUL, DIG 99997 FORMAT (1X,6E12.4/) ! ------------------------------------------------------------------ ! Set other constants needed in the tests. ! ------------------------------------------------------------------ end if CONE = (1.0E0,0.0E0) HPI = 2.0E0*ATAN(1.0E0) ! ------------------------------------------------------------------ ! Generate angles for construction of complex Z to be used in tests. ! ------------------------------------------------------------------ ! KDO(K), K = 1,IL determines which of the IL angles in -PI to PI ! are used to compute values of Z. ! KDO(K) = 0 means that the index K will be used for one or two ! values of Z, depending on the choice of KEPS(K) ! = 1 means that the index K and the corresponding angle ! will be skipped ! KEPS(K), K = 1,IL determines which of the angles get incremented ! up and down to put values of Z in regions where different ! formulae are used. ! KEPS(K) = 0 means that the angle will be used without change ! = 1 means that the angle will be incremented up and ! down by EPS ! The angles to be used are stored in the T(I) array, I = 1,ITL. ! ------------------------------------------------------------------ PI = HPI + HPI if ( MQC /= 2 ) then NL = 2 IL = 5 DO 5 I = 1,IL KEPS(I) = 0 KDO(I) = 0 5 continue NUL = 5 XNU(1) = 0.0E0 XNU(2) = 1.0E0 XNU(3) = 2.0E0 XNU(4) = 0.5E0*FNUL XNU(5) = FNUL + 1.1E0 else NL = 4 IL = 13 DO 6 I = 1,IL KDO(I) = 0 KEPS(I) = 0 6 continue KDO(2) = 1 KDO(6) = 1 KDO(8) = 1 KDO(12) = 1 KEPS(3) = 1 KEPS(4) = 1 KEPS(5) = 1 KEPS(9) = 1 KEPS(10) = 1 KEPS(11) = 1 NUL = 6 XNU(1) = 0.0E0 XNU(2) = 0.6E0 XNU(3) = 1.3E0 XNU(4) = 2.0E0 XNU(5) = 0.5E0*FNUL XNU(6) = FNUL + 1.1E0 end if I = 2 EPS = 0.01E0 FILM = IL - 1 T(1) = -PI + EPS DO 30 K = 2,IL if ( KDO(K) == 0 ) then T(I) = PI*(-IL+2*K-1)/FILM if ( KEPS(K) /= 0 ) then TS = T(I) T(I) = TS - EPS I = I + 1 T(I) = TS + EPS else I = I + 1 end if end if 30 continue ! ------------------------------------------------------------------ ! Test values of Z IN -PI.lt.arg(Z).le.PI near formula boundaries. ! ------------------------------------------------------------------ ITL = I - 1 if ( KPRINT >= 2 ) then write (LUN,99996) 99996 FORMAT (' CHECKS IN THE (Z,FNU) SPACE') end if LFLG = 0 DO 200 KODE = 1,2 DO 190 N = 1,NL N1 = N + 1 DO 180 NU = 1,NUL FNU = XNU(NU) IFNU = INT(FNU) FFNU = FNU - IFNU ARG = PI*FFNU CSGN = CMPLX(COS(ARG),SIN(ARG)) if ( MOD(IFNU,2) == 1 ) then CSGN = -CSGN end if DO 170 ICASE = 1,3 IRB = min ( 2,ICASE) ! --------- switch (icase) DO 160 IR = IRB,4 GO TO (50, 60, 70), ICASE 50 continue R = (EPS*(4-IR)+2.0E0*(IR-1))/3.0E0 GO TO 80 60 continue R = (2.0E0*(4-IR)+R2*(IR-1))/3.0E0 GO TO 80 70 continue if ( R2 >= RM) GO TO 170 R = (R2*(4-IR)+RM*(IR-1))/3.0E0 ! --------- end switch 80 continue DO 150 IT = 1,ITL CT = COS(T(IT)) ST = SIN(T(IT)) if ( ABS(CT) < ATOL) CT = 0.0E0 if ( ABS(ST) < ATOL) ST = 0.0E0 Z = CMPLX(R*CT,R*ST) ! ----------- Underflow? - skip test for this case. call CBESI(Z, FNU, KODE, N1, W, NZ2, IERR) ! ------------------------------------------------------------------ ! In the left half plane, the analytic continuation formula for K ! introduces an I function. The dominant terms in the Wronskian ! I(FNU,Z)*I(FNU+1,Z) cancel out, giving losses of significance. ! This cancellation can be done analytically to give a Wronskian in ! terms of I in the left half plane and K in the right half plane. ! ------------------------------------------------------------------ if ( NZ2 /= 0) GO TO 150 ! ------------- Z is in the right half plane if ( ICASE == 1.OR.CT >= 0.0E0 ) then call CBESK(Z, FNU, KODE, N1, Y, NZ1, IERR) CV = CONE/Z ! --------------- Adjust Wronskian due to scaled I and K functions if ( KODE == 2 ) then XX = REAL(Z) AXX = ABS(XX) ZN = CMPLX(-AXX,0.0E0) CV = ZN + Z CV = EXP(CV)/Z end if ! ------------- Z is in the left half plane else ZN = -Z call CBESK(ZN, FNU, KODE, N1, Y, NZ1, IERR) ! ------------- CSGN set near top of DO 180 loop ZN = CSGN if ( ST > 0.0E0 .OR. (ST == 0.0E0 .and. CT < 0.0E0)) & ZN = CONJG(ZN) DO 90 KK = 1,N1 Y(KK) = Y(KK)*ZN ZN = -ZN 90 continue CV = CONE/Z ! --------------- Adjust Wronskian due to scaled I and K functions if ( KODE == 2 ) then XX = REAL(Z) AXX = ABS(XX) ZN = CMPLX(-AXX,0.0E0) CV = ZN - Z CV = EXP(CV)/Z end if end if MFLG = 0 DO 130 I = 1,N CW = W(I)*Y(I+1) CY = W(I+1)*Y(I) CY = CY + CW - CV ER = ABS(CY)/ABS(CV) AER(I) = ER if ( ER > ERTOL ) then MFLG = 1 end if 130 continue if ( MFLG /= 0 ) then if ( LFLG == 0 ) then if ( KPRINT >= 2 ) then write (LUN,99995) ERTOL 99995 FORMAT (/' CASES WHICH OR VIOLATE THE RELATIVE', & ' ERROR TEST WITH ERTOL = ', E12.4/) write (LUN,99994) 99994 FORMAT (' INPUT TO CBESK Z, FNU, KODE, N') end if if ( KPRINT >= 3 ) then write (LUN,99993) 99993 FORMAT (' ERROR TEST ON THE WRONSKIAN OF ', & 'CBESI(Z,FNU) AND CBESK(Z,FNU)') write (LUN,99992) 99992 FORMAT (' RESULTS FROM CBESK NZ1, Y(KK)'/, & ' RESULTS FROM CBESI NZ2, W(KK)') write (LUN,99991) 99991 FORMAT (' TEST CASE INDICES IT, IR, ICASE'/) end if end if LFLG = LFLG + 1 if ( KPRINT >= 2 ) then write (LUN,99990) Z, FNU, KODE, N 99990 FORMAT (' INPUT: Z=',2E12.4,4X,'FNU=',E12.4, & 4X,'KODE=',I3,4X,'N=',I3) end if if ( KPRINT >= 3 ) then write (LUN,99989) (AER(K),K=1,N) 99989 FORMAT (' ERROR: AER(K)=',4E12.4) KK = max ( NZ1,NZ2) + 1 KK = min ( N,KK) write (LUN,99988) NZ1, Y(KK), NZ2, W(KK) 99988 FORMAT (' RESULTS: NZ1=',I3,4X,'Y(KK)=',2E12.4, & /11X,'NZ2=',I3,4X,'W(KK)=',2E12.4) write (LUN,99987) IT, IR, ICASE 99987 FORMAT (' CASE: IT=',I3,4X,'IR=',I3,4X, & 'ICASE=',I3/) end if end if 150 continue 160 continue 170 continue 180 continue 190 continue 200 continue if ( KPRINT >= 2 ) then if ( LFLG == 0 ) then write (LUN,99986) 99986 FORMAT (' QUICK CHECKS OK') else write (LUN,99985) LFLG 99985 FORMAT (' ***',I5,' FAILURE(S) FOR CBESK NEAR FORMULA ', & 'BOUNDARIES') end if end if ipass = 0 if ( LFLG == 0 ) then ipass = 1 end if if ( ipass == 1 .and. KPRINT >= 2 ) then write (LUN,99984) 99984 FORMAT (/' ****** CBESK PASSED ALL TESTS ******'/) end if if ( ipass == 0 .and. KPRINT >= 1 ) then write (LUN,99983) 99983 FORMAT (/' ****** CBESK FAILED SOME TESTS ******'/) end if return end !! CQCBY !***SUBSIDIARY !***PURPOSE Quick check for SLATEC subroutine ! CBESY !***LIBRARY SLATEC !***CATEGORY C10A4 !***TYPE COMPLEX (CQCBY-C, ZQCBY-Z) !***KEYWORDS QUICK CHECK, CBESY !***AUTHOR Amos, Don, (SNL) ! Goudy, Sue, (SNL) ! Walton, Lee, (SNL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call CQCBY (LUN, KPRINT, IPASS) ! ! *Arguments: ! ! LUN :IN is the unit number to which output is to be written. ! ! kprint :IN controls the amount of output, as specified in the ! SLATEC Guidelines. ! ! ipass :OUT indicates whether the test passed or failed. ! A value of one is good, indicating no failures. ! ! *Description: ! ! CQCBY is a quick check routine for the complex Y Bessel function ! generated by subroutine CBESY. ! ! CQCBY generates sequences of Y Bessel functions from CBESY ! and checks them against the evaluation from the formula ! ! Y(FNU,Z*ROT) = C(FNU+1)*I(FNU,Z)-(2/PI)*CONJG(C(FNU))*K(FNU,Z) ! ! where ROT = EXP(PI*I/2) , C(FNU)=EXP(PI*FNU*I/2) , I**2=-1 ! ! and -PI < ARG(Z) <= PI/2, in the (Z,FNU) space. ! !***REFERENCES Abramowitz, M. and Stegun, I. A., Handbook ! of Mathematical Functions, Dover Publications, ! New York, 1964. ! Amos, D. E., A Subroutine Package for Bessel ! Functions of a Complex Argument and Nonnegative ! Order, SAND85-1018, May, 1985. !***ROUTINES CALLED CBESI, CBESK, CBESY, i1mach, R1MACH !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890831 Revised to meet new SLATEC standards ! !***END PROLOGUE CQCBY ! !*Internal Notes: ! Machine constants are defined by functions i1mach and R1MACH. ! ! The parameter MQC can have values 1 (the default) for a faster, ! less definitive test or 2 for a slower, more definitive test. ! !**End ! ! Set test complexity parameter. ! subroutine CQCBY (LUN, KPRINT, IPASS) integer MQC ! ! Declare arguments. ! PARAMETER (MQC=1) ! ! Declare external functions. ! integer LUN, KPRINT, IPASS integer i1mach REAL R1MACH ! ! Declare local variables. ! EXTERNAL i1mach, R1MACH COMPLEX CI, CIP, COE1, COE2, CSGN, CSPN, CW, CWRK, V, W, Y, Z, ZN REAL AA, AB, AER, ALIM, ARG, ATOL, AV, CC, CT, DIG, ELIM, EPS, & ER, ERTOL, FFNU, FILM, FNU, FNUL, HPI, PI, R, RHPI, RL, RM, & R1M4, R1M5, R2, SLAK, ST, T, TOL, TS, XN, XNU, XX, YN, YY integer I, ICASE, IERR, IFNU, IL, IR, IRB, IT, ITL, I4, K, KDO, & KEPS, KK, KODE, K1, K2, LFLG, MFLG, N, NL, NU, NUL, NZ, NZ1, & NZ2 dimension AER(20), CIP(4), CWRK(20), KDO(20), KEPS(20), T(20), & V(20), W(20), XNU(20), Y(20) DATA CIP(1), CIP(2), CIP(3), CIP(4) / & ! !***FIRST EXECUTABLE STATEMENT CQCBY (1.0E0,0.0E0), (0.0E0,1.0E0), (-1.0E0,0.0E0), (0.0E0,-1.0E0) / if ( KPRINT >= 2 ) then write (LUN,99999) 99999 FORMAT (' QUICK CHECK ROUTINE FOR THE Y BESSEL FUNCTION FROM ', & 'CBESY'/) ! ------------------------------------------------------------------ ! Set parameters related to machine constants. ! TOL is the approximate unit roundoff limited to 1.0E-18. ! ELIM is the approximate exponential over- and underflow limit. ! exp(-ELIM).lt.exp(-ALIM)=exp(-ELIM)/TOL and ! exp(ELIM).gt.exp(ALIM)=exp(ELIM)*TOL are intervals near ! underflow and overflow limits where scaled arithmetic is done. ! RL is the lower boundary of the asymptotic expansion for large Z. ! DIG = number of base 10 digits in TOL = 10**(-DIG). ! FNUL is the lower boundary of the asymptotic series for large FNU. ! ------------------------------------------------------------------ end if R1M4 = R1MACH(4) TOL = max ( R1M4,1.0E-18) ATOL = 100.0E0*TOL AA = -LOG10(R1M4) K1 = i1mach(12) K2 = i1mach(13) R1M5 = R1MACH(5) K = min ( ABS(K1),ABS(K2)) ELIM = 2.303E0*(K*R1M5-3.0E0) AB = AA*2.303E0 ALIM = ELIM + max ( -AB,-41.45E0) DIG = min ( AA,18.0E0) FNUL = 10.0E0 + 6.0E0*(DIG-3.0E0) RL = 1.2E0*DIG + 3.0E0 SLAK = 3.0E0+4.0E0*(-LOG10(TOL)-7.0E0)/11.0E0 SLAK = max ( SLAK,3.0E0) ERTOL = TOL*10.0E0**SLAK RM = 0.5E0*(ALIM + ELIM) RM = min ( RM,200.0E0) RM = max ( RM,RL+10.0E0) R2 = min ( RM,FNUL) if ( KPRINT >= 2 ) then write (LUN,99998) 99998 FORMAT (' PARAMETERS'/ & 5X,'TOL ',8X,'ELIM',8X,'ALIM',8X,'RL ',8X,'FNUL',8X,'DIG') write (LUN,99997) TOL, ELIM, ALIM, RL, FNUL, DIG 99997 FORMAT (1X,6E12.4/) ! ------------------------------------------------------------------ ! Set other constants needed in the tests. ! ------------------------------------------------------------------ end if CI = (0.0E0,1.0E0) HPI = 2.0E0*ATAN(1.0E0) RHPI = 1.0E0/HPI ! ------------------------------------------------------------------ ! Generate angles for construction of complex Z to be used in tests. ! ------------------------------------------------------------------ ! KDO(K), K = 1,IL determines which of the IL angles in -PI to PI ! are used to compute values of Z. ! KDO(K) = 0 means that the index K will be used for one or two ! values of Z, depending on the choice of KEPS(K) ! = 1 means that the index K and the corresponding angle ! will be skipped ! KEPS(K), K = 1,IL determines which of the angles get incremented ! up and down to put values of Z in regions where different ! formulae are used. ! KEPS(K) = 0 means that the angle will be used without change ! = 1 means that the angle will be incremented up and ! down by EPS ! The angles to be used are stored in the T(I) array, I = 1,ITL. ! ------------------------------------------------------------------ PI = HPI + HPI if ( MQC /= 2 ) then NL = 2 IL = 5 DO 5 I = 1,IL KEPS(I) = 0 KDO(I) = 0 5 continue KDO(5) = 1 NUL = 5 XNU(1) = 0.0E0 XNU(2) = 1.0E0 XNU(3) = 2.0E0 XNU(4) = 0.5E0*FNUL XNU(5) = FNUL + 1.2E0 else NL = 4 IL = 13 DO 6 I = 1,IL KDO(I) = 0 KEPS(I) = 0 6 continue KDO(2) = 1 KDO(6) = 1 KDO(8) = 1 KDO(11) = 1 KDO(12) = 1 KDO(13) = 1 KEPS(3) = 1 KEPS(4) = 1 KEPS(5) = 1 KEPS(9) = 1 NUL = 6 XNU(1) = 0.0E0 XNU(2) = 0.6E0 XNU(3) = 1.3E0 XNU(4) = 2.0E0 XNU(5) = 0.5E0*FNUL XNU(6) = FNUL + 1.2E0 end if I = 2 EPS = 0.01E0 FILM = IL - 1 T(1) = -PI + EPS DO 30 K = 2,IL if ( KDO(K) == 0 ) then T(I) = PI*(-IL+2*K-1)/FILM if ( KEPS(K) /= 0 ) then TS = T(I) T(I) = TS - EPS I = I + 1 T(I) = TS + EPS else I = I + 1 end if end if 30 continue ! ------------------------------------------------------------------ ! Test values of Z in -PI/2.lt.arg(Z).le.PI ! ------------------------------------------------------------------ ITL = I - 1 if ( KPRINT >= 2 ) then write (LUN,99996) 99996 FORMAT (' CHECKS IN THE (Z,FNU) SPACE') end if LFLG = 0 DO 190 KODE = 1,2 DO 180 N = 1,NL ! ------------------------------------------------------------------ ! Construct values which will be used to set ! COE1 = exp(i*(FNU+1)*PI/2) and ! COE2 = (2/pi)*exp(-i*FNU*PI/2). ! ------------------------------------------------------------------ DO 170 NU = 1,NUL FNU = XNU(NU) IFNU = INT(FNU) FFNU = FNU - IFNU ARG = HPI*FFNU CSGN = CMPLX(COS(ARG),SIN(ARG)) I4 = MOD(IFNU,4) + 1 CSGN = CSGN*CIP(I4) CSPN = CONJG(CSGN)*CMPLX(RHPI,0.0E0) CSGN = CSGN*CI DO 160 ICASE = 1,3 IRB = min ( 2,ICASE) ! --------- switch (icase) DO 150 IR = IRB,4 GO TO (50, 60, 70), ICASE 50 continue R = (EPS*(4-IR)+2.0E0*(IR-1))/3.0E0 GO TO 80 60 continue R = (2.0E0*(4-IR)+R2*(IR-1))/3.0E0 GO TO 80 70 continue if ( R2 >= RM) GO TO 160 R = (R2*(4-IR)+RM*(IR-1))/3.0E0 ! --------- end switch 80 continue DO 140 IT = 1,ITL CT = COS(T(IT)) ST = SIN(T(IT)) if ( ABS(CT) < ATOL) CT = 0.0E0 if ( ABS(ST) < ATOL) ST = 0.0E0 Z = CMPLX(R*CT,R*ST) XX = REAL(Z) YY = AIMAG(Z) ! ----------- Underflow in CBESI - skip test for this case. call CBESI(Z, FNU, KODE, N, W, NZ2, IERR) if ( NZ2 /= 0) GO TO 140 ! ----------- Underflow in CBESK - skip test for this case. call CBESK(Z, FNU, KODE, N, Y, NZ1, IERR) if ( NZ1 /= 0) GO TO 140 ZN = Z*CI XN = -YY YN = XX ! ----------- Underflow in CBESY - skip test for this case. call CBESY(ZN, FNU, KODE, N, V, NZ, CWRK, IERR) if ( NZ /= 0) GO TO 140 COE1 = CSGN COE2 = CSPN ! ------------- Adjust scale for I and K functions. if ( KODE == 2 ) then CC = -XX - ABS(XX) if ( CC > (-ALIM) ) then CW = CMPLX(CC,-YY) COE2 = COE2*EXP(CW) ! --------------- Scaling problem - skip test for this case else COE2 = CMPLX(0.0E0,0.0E0) GO TO 140 end if end if DO 110 KK = 1,N Y(KK) = Y(KK)*COE2 W(KK) = W(KK)*COE1 COE1 = COE1*CI COE2 = -COE2*CI ! ------------------------------------------------------------------ ! Compare Y(ZN,FNU) with COE1*I(Z,FNU)-COE2*K(Z,FNU). ! ------------------------------------------------------------------ 110 continue MFLG = 0 DO 120 I = 1,N AB = FNU + I - 1 AA = max ( 0.5E0,AB) CW = W(I) - Y(I) AV = CABS(V(I)) ER = CABS(CW-V(I)) if ( AV /= 0.0E0 ) then if ( YN == 0.0E0 ) then if ( XN > 0.0E0 ) then if ( ABS(XN) < AA) ER = ER/AV else if ( ABS(FFNU-0.5E0) < 0.125E0 ) then if ( ABS(XN) < AA) ER = ER/AV else ER = ER/AV end if end if else ER = ER/AV end if end if AER(I) = ER if ( ER > ERTOL) MFLG = 1 120 continue if ( MFLG /= 0 ) then if ( LFLG == 0 ) then if ( KPRINT >= 2 ) then write (LUN,99995) ERTOL 99995 FORMAT (/' CASES WHICH VIOLATE THE RELATIVE ', & 'ERROR TEST WITH ERTOL = ',E12.4/) write (LUN,99994) 99994 FORMAT (' INPUT TO CBESY ZN, FNU, KODE, N') end if if ( KPRINT >= 3 ) then write (LUN,99993) 99993 FORMAT (' COMPARE Y(ZN,FNU) WITH COE1*I(Z,FNU)', & '-COE2*K(Z,FNU)') write (LUN,99992) 99992 FORMAT (' Z = ZN*EXP(-i*PI/2)'/ & ' COE1 = EXP(i*(FNU+1)*PI/2) ', & ' COE2 = (2/PI)*EXP(-i*FNU*PI/2)') write (LUN,99991) 99991 FORMAT (' RESULTS FROM CBESY V(KK)'/ & 9X,'FROM CBESI W(KK)'/ & 9X,'FROM CBESK Y(KK)') write (LUN,99990) 99990 FORMAT (' TEST CASE INDICES IR, IT, ICASE'/) end if end if LFLG = LFLG + 1 if ( KPRINT >= 2 ) then write (LUN,99989) ZN, FNU, KODE, N 99989 FORMAT (' INPUT: ZN=',2E12.4,3X,'FNU=',E12.4, & 3X,'KODE=',I3,3X,'N=',I3) end if if ( KPRINT >= 3 ) then write (LUN,99988) (AER(K),K=1,N) 99988 FORMAT (' ERROR: AER(K)=',4E12.4) write (LUN,99987) Z, COE1, COE2 99987 FORMAT (12X,'Z=',2E12.4/12X,'COE1=',2E12.4,3X, & 'COE2=',2E12.4) KK = max ( NZ1,NZ2) + 1 KK = min ( N,KK) write (LUN,99986) V(KK), W(KK), Y(KK) 99986 FORMAT (' RESULTS: V(KK)=',2E12.4/ & 12X,'W(KK)=',2E12.4/12X,'Y(KK)=',2E12.4) write (LUN,99985) IR, IT, ICASE 99985 FORMAT (' CASE: IR=',I3,3X,'IT=',I3,3X, & 'ICASE=',I3/) end if end if 140 continue 150 continue 160 continue 170 continue 180 continue 190 continue if ( KPRINT >= 2 ) then if ( LFLG == 0 ) then write (LUN,99984) 99984 FORMAT (' QUICK CHECKS OK') else write (LUN,99983) LFLG 99983 FORMAT (' ***',I5,' FAILURE(S) FOR CBESY IN THE (Z,FNU) ', & 'PLANE') end if end if ipass = 0 if ( LFLG == 0 ) then ipass = 1 end if if ( ipass == 1 .and. KPRINT >= 2 ) then write (LUN,99982) 99982 FORMAT (/' ****** CBESY PASSED ALL TESTS ******'/) end if if ( ipass == 0 .and. KPRINT >= 1 ) then write (LUN,99981) 99981 FORMAT (/' ****** CBESY FAILED SOME TESTS ******'/) end if return end !! CQCK !***PURPOSE Quick check for CPOFS, CPOIR, CNBFS and CNBIR. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! QUICK CHECK SUBROUTINE CQCK TESTS THE EXECUTION OF THE ! SLATEC SUBROUTINES CPOFS, CPOIR, CNBFS AND CNBIR. ! A TITLE LINE AND A SUMMARY LINE ARE ALWAYS OUTPUTTED. ! ! THE SUMMARY LINE GIVES A COUNT OF THE NUMBER OF ! PROBLEMS ENCOUNTERED IN THE TEST IF ANY EXIST. CQCK ! CHECKS COMPUTED VS. EXACT SOLUTIONS TO AGREE TO ! WITHIN 0.8 TIMES THE WORD LENGTH OF THE COMPUTER ! (1.6 IF DOUBLE PRECISION) FOR CASE 1. CQCK ALSO ! TESTS ERROR HANDLING BY THE SUBROUTINE (CALLS TO ! XERMSG (CQCK SETS IFLAG/KONTRL TO 0)) ! USING A SINGULAR MATRIX FOR CASE 2. EACH EXECUTION ! PROBLEM DETECTED BY CQCK RESULTS IN AN ADDITIONAL ! EXPLANATORY LINE OF OUTPUT. ! ! CQCK REQUIRES NO INPUT ARGUMENTS. ! ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT ! OF ALL PROBLEMS DETECTED BY CQCK. ! !***ROUTINES CALLED CNBFS, CNBIR, CPOFS, CPOIR, R1MACH !***REVISION HISTORY (YYMMDD) ! 801002 DATE WRITTEN ! 891009 Removed unreferenced statement labels. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901009 Restructured using IF-THEN-else-end if, cleaned up FORMATs, ! including removing an illegal character from column 1, and ! editorial changes. (RWC) !***END PROLOGUE CQCK subroutine CQCK (LUN, KPRINT, NERR) REAL R,DELX,DELMAX,R1MACH COMPLEX A(4,4),AT(5,4),ABE(5,7),ABET(5,7),B(4),BT(4),C(4),WORK(35) CHARACTER*4 LIST(4) integer LDA,N,ML,MU,IND,IWORK(4),NERR,I,J,J1,J2,JD,MLP,K,KCASE, & KPROG DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA B/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ !***FIRST EXECUTABLE STATEMENT CQCK DATA LIST/'POFS', 'POIR', 'NBFS', 'NBIR'/ if ( KPRINT >= 3) write (LUN,800) LDA = 5 N = 4 ML = 2 MU = 1 JD = 2*ML+MU+1 NERR = 0 ! ! FORM ABE(NB ARRAY) FROM MATRIX A. ! R = R1MACH(4)**0.8E0 DO 30 J=1,JD DO 20 I=1,N ABE(I,J) = (0.0E0,0.0E0) 20 continue ! 30 continue MLP = ML+1 DO 50 I=1,N J1 = max ( 1,I-ML) J2 = min ( N,I+MU) DO 40 J=J1,J2 K = J-I+MLP ABE(I,K) = A(I,J) 40 continue ! ! CASE 1 FOR WELL-CONDITIONED MATRIX, CASE 2 FOR SINGULAR MATRIX ! 50 continue DO 170 KCASE=1,2 ! FORM BT FROM B, AT FROM A, AND ABET FROM ABE. DO 140 KPROG=1,4 DO 60 I=1,N BT(I) = B(I) DO 58 J=1,N AT(I,J) = A(I,J) 58 continue ! 60 continue DO 80 J=1,JD DO 70 I=1,N ABET(I,J) = ABE(I,J) 70 continue ! ! MAKE AT AND ABET SINGULAR FOR CASE = 2 ! 80 continue if ( KCASE == 2 ) then DO 88 J=1,N AT(1,J) = (0.0E0,0.0E0) ! 88 continue DO 90 J=1,JD ABET(1,J) = (0.0E0,0.0E0) 90 continue ! ! SOLVE FOR X ! end if if ( KPROG == 1) call CPOFS (AT,LDA,N,BT,1,IND,WORK) if ( KPROG == 2) call CPOIR (AT,LDA,N,BT,1,IND,WORK) if ( KPROG == 3) call CNBFS (ABET,LDA,N,ML,MU,BT,1,IND,WORK, & IWORK) if ( KPROG == 4) call CNBIR (ABET,LDA,N,ML,MU,BT,1,IND,WORK, & ! ! COMPARE EXACT AND COMPUTED SOLUTIONS FOR CASE 1 ! IWORK) if ( KCASE == 1 ) then DELMAX = 0.0E0 DO 110 I=1,N DELX = ABS(REAL(BT(I))-REAL(C(I))) DELMAX = max ( DELMAX,DELX) DELX = ABS(AIMAG(BT(I))-AIMAG(C(I))) DELMAX = max ( DELMAX,DELX) ! 110 continue if ( R <= DELMAX ) then NERR = NERR+1 write (LUN,801) LIST(KPROG),KCASE,DELMAX end if ! CHECK CONTROL FOR SINGULAR MATRIX FOR CASE 2 ! else if ( IND /= -4 ) then NERR = NERR+1 write (LUN,802) LIST(KPROG),KCASE,IND end if end if 140 continue ! ! SUMMARY PRINT ! 170 continue if ( NERR /= 0) write (LUN,803) NERR if ( KPRINT >= 2 .and. NERR == 0) write (LUN,804) ! return 800 FORMAT (/' * CQCK - QUICK CHECK FOR CPOFS, CPOIR, CNBFS AND ', & 'CNBIR'/) 801 FORMAT (' PROBLEM WITH C', A, ', CASE ', I1, & '. MAX ABS ERROR OF', E11.4/) 802 FORMAT (' PROBLEM WITH C', A, ', CASE ', I1, '. IND = ', I2, & ' INSTEAD OF -4'/) 803 FORMAT (/' **** CQCK DETECTED A TOTAL OF ', I2,' PROBLEMS. ****'/) 804 FORMAT (' CQCK DETECTED NO PROBLEMS.'/) end !! CQNG !***PURPOSE Quick check for QNG. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (CQNG-S, CDQNG-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED CPRIN, F1N, F2N, QNG, R1MACH !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Added PASS/FAIL message and changed the name of the first ! argument. (RWC) ! 910501 Added PURPOSE and TYPE records. (WRB) !***END PROLOGUE CQNG ! ! FOR FURTHER DOCUMENTATION SEE ROUTINE CQPDOC ! subroutine CQNG (LUN, KPRINT, IPASS) REAL A,ABSERR,B,R1MACH,EPMACH,EPSABS,EPSREL,EXACT1,ERROR, & EXACT2,F1N,F2N,RESULT,UFLOW integer IER,IERV,IP,IPASS,KPRINT,NEVAL dimension IERV(1) EXTERNAL F1N,F2N DATA EXACT1/0.7281029132255818E+00/ !***FIRST EXECUTABLE STATEMENT CQNG DATA EXACT2/0.1E+02/ ! ! TEST ON IER = 0 ! if ( KPRINT >= 2) write (LUN, '(''1QNG QUICK CHECK''/)') ipass = 1 EPSABS = 0.0E+00 EPMACH = R1MACH(4) UFLOW = R1MACH(1) EPSREL = max ( SQRT(EPMACH),0.1E-07) A = 0.0E+00 B = 0.1E+01 call QNG(F1N,A,B,EPSABS,EPSREL,RESULT,ABSERR,NEVAL,IER) IERV(1) = IER IP = 0 ERROR = ABS(EXACT1-RESULT) if ( IER == 0 .and. ERROR <= ABSERR.AND.ABSERR <= EPSREL*ABS(EXACT1)) & IP = 1 if ( IP == 0) ipass = 0 if ( kprint /= 0) call CPRIN(LUN,0,KPRINT,IP,EXACT1,RESULT,ABSERR, & ! ! TEST ON IER = 1 ! NEVAL,IERV,1) call QNG(F2N,A,B,UFLOW,0.0E+00,RESULT,ABSERR,NEVAL,IER) IERV(1) = IER IP = 0 if ( IER == 1) IP = 1 if ( IP == 0) ipass = 0 if ( kprint /= 0) call CPRIN(LUN,1,KPRINT,IP,EXACT2,RESULT,ABSERR, & ! ! TEST ON IER = 6 ! NEVAL,IERV,1) EPSABS = 0.0E+00 EPSREL = 0.0E+00 call QNG(F1N,A,B,EPSABS,0.0E+00,RESULT,ABSERR,NEVAL,IER) IERV(1) = IER IP = 0 if ( IER == 6 .and. RESULT == 0.0E+00.AND.ABSERR == 0.0E+00.AND. & NEVAL == 0) IP = 1 if ( IP == 0) ipass = 0 if ( kprint /= 0) call CPRIN(LUN,6,KPRINT,IP,EXACT1,RESULT,ABSERR, & ! NEVAL,IERV,1) if ( KPRINT >= 1 ) then if ( ipass == 0 ) then write (LUN, '(/'' SOME TEST(S) IN CQNG FAILED''/)') elseif ( KPRINT >= 2 ) then write (LUN, '(/'' ALL TEST(S) IN CQNG PASSED''/)') end if end if return end !! CQRQC !***PURPOSE Quick check for CQRDC and CQRSL. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! THE RETURNED FLOATING POINT VALUES FROM CQRDC AND CQRSL FOR ! FACTORED X, QRAUX, QY, QTY, B, RSD, AND XB ARE COMPARED TO ! THEIR CORRESPONDING STORED PRE-COMPUTED VALUES (ENTERED ! WITH DATA STATEMENTS). FAILURE OF THE TEST OCCURS WHEN ! AGREEMENT TO 3 SIGNIFICANT DIGITS IS NOT ACHIEVED AND AN ! ERROR MESSAGE IS THEN PRINTED. ! ! THE RETURNED INTEGER VALUES OF JPVT AND INFO ARE ALSO CHECKED. ! LACK OF AGREEMENT RESULTS IN AN ERROR MESSAGE. A SUMMARY ! LINE IS ALWAYS PRINTED. ! ! NO INPUT ARGUMENTS ARE REQUIRED. ON RETURN, NERR (INTEGER ! TYPE) CONTAINS THE TOTAL COUNT OF ALL FAILURES DETECTED. ! !***ROUTINES CALLED CQRDC, CQRSL !***REVISION HISTORY (YYMMDD) ! 801029 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if, moved an ARITHMETIC ! STATEMENT FUNCTION ahead of the FIRST EXECUTABLE STATEMENT ! record and cleaned up FORMATs. (RWC) !***END PROLOGUE CQRQC subroutine CQRQC (LUN, KPRINT, NERR) COMPLEX A(4,4),QRAUX(4),WORK(4),Y(4),QY(4),QTY(4),B(4),RSD(4),XB(4 & ) COMPLEX AT(5,4),AC(4,4),QRAUXC(4),QYC(4),QTYC(4),BC(4),RSDC(4),XBC & (4),X1,X2 CHARACTER KPROG*9,KFAIL*75 integer LDX,N,P,JPVT(4),JOB,K,INFO integer JPVTT(4),JPVTC(4),I,J,INDX(5),NERR,L REAL DELX DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA JPVT/0,-1,1,0/ DATA Y/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA AC/(-3.16228E0,0.E0),(0.E0,0.E0),(.94868E0,0.E0), & (0.E0,.31623E0),(0.E0,2.21359E0),(-3.47851E0,0.E0), & (0.E0,.31623E0),(.94868E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (2.23607E0,0.E0),(0.E0,.70711E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,-1.78885E0),(-1.34164E0,0.E0)/ DATA QRAUXC/(1.E0,0.E0),(1.E0,0.E0),(1.70711E0,0.E0),(0.E0,0.E0)/ DATA JPVTC/3,4,1,2/ DATA QYC/(0.E0,-5.81378E0),(-2.68328E0,0.E0), & (-1.89737E0,-1.58114E0),(1.58114E0,-3.79473E0)/ DATA QTYC/(0.E0,5.37587E0),(-3.47851E0,0.E0), & (4.02492E0,2.23607E0),(0.E0,-1.34164E0)/ DATA BC/(0.E0,-1.E0),(1.E0,0.E0),(1.E0,1.E0),(0.E0,1.E0)/ DATA RSDC/(0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0)/ DATA XBC/(3.E0,2.E0),(-1.E0,3.E0),(0.E0,-4.E0),(5.E0,0.E0)/ DATA KPROG/'QRDC QRSL'/ DATA KFAIL/'FACTOR QRAUX JPVT QY QTY SOLUTION RSD XB INFO'/ !***FIRST EXECUTABLE STATEMENT CQRQC DELX(X1,X2) = ABS(REAL(X1-X2))+ABS(AIMAG(X1-X2)) LDX = 5 N = 4 P = 4 K = 4 ! ! FORM AT AND JPVTT ! NERR = 0 DO J=1,N JPVTT(J) = JPVT(J) DO I=1,N AT(I,J) = A(I,J) end do end do ! ! TEST CQRDC (FACTOR, QRAUX, JPVT) ! JOB = 1 call CQRDC(AT,LDX,N,P,QRAUX,JPVTT,WORK,JOB) INDX(1) = 0 DO J=1,N DO I=1,N if ( DELX(AT(I,J),AC(I,J)) > .0001) INDX(1) = INDX(1)+1 end do end do if ( INDX(1) /= 0 ) then write (LUN, 501) KPROG(1:4),KFAIL(1:6) NERR = NERR + 1 end if DO I=1,2 INDX(I) = 0 end do DO I=1,N if ( DELX(QRAUX(I),QRAUXC(I)) > .0001) INDX(1) = INDX(1)+1 if ( JPVTT(I) /= JPVTC(I)) INDX(2) = INDX(2)+1 end do DO I=1,2 L = 7*I+1 if ( INDX(I) /= 0 ) then write (LUN,501) KPROG(1:4),KFAIL(L:L+4) NERR = NERR + 1 end if end do ! ! TEST CQRSL (QY, QTY, SOLUTION, RSD, XB, INFO) ! JOB = 11111 INDX(1:5) = 0 call CQRSL(AT,LDX,N,K,QRAUX,Y,QY,QTY,B,RSD,XB,JOB,INFO) DO I=1,N if ( DELX(QY(I),QYC(I)) > .0001) INDX(1) = INDX(1)+1 if ( DELX(QTY(I),QTYC(I)) > .0001) INDX(2) = INDX(2)+1 if ( DELX(B(I),BC(I)) > .0001) INDX(3) = INDX(3)+1 if ( DELX(RSD(I),RSDC(I)) > .0001) INDX(4) = INDX(4)+1 if ( DELX(XB(I),XBC(I)) > .0001) INDX(5) = INDX(5)+1 end do DO I=1,5 L = 10*I+11 if ( INDX(I) /= 0 ) then write (LUN,501) KPROG(6:9),KFAIL(L:L+8) NERR = NERR + 1 end if end do if ( INFO /= 0 ) then write (LUN,501) KPROG(6:9),KFAIL(71:74) NERR = NERR + 1 end if if ( KPRINT >= 2 .OR. NERR /= 0) write (LUN,500) NERR return 500 FORMAT(/' * CQRQC - TEST FOR CQRDC AND CQRSL FOUND ', I1, & ' ERRORS.'/) 501 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) end !! CQRTST !***PURPOSE Quick check for CPQR79. !***LIBRARY SLATEC !***TYPE COMPLEX (RQRTST-S, CQRTST-C) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED CPQR79, NUMXER, PASS, R1MACH, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Changed usage of R1MACH(3) to R1MACH(4). (RWC) ! 911010 Code reworked and simplified. (RWC and WRB) !***END PROLOGUE CQRTST subroutine CQRTST (LUN, KPRINT, IPASS) integer ITEST(2), ITMP(7) REAL WORK(144) COMPLEX COEFF1(9), COEFF2(2), COEFF3(2), ROOT(8), CHK1(8), CHK2 ! LOGICAL FATAL DATA COEFF1 / (1.0,0.0), (-7.0,-2.0), (8.0,6.0), (28.0, 8.0), & (-49.0,-24.0), (7.0,2.0), (-8.0,-6.0), & (-28.0,-8.0), (48.0,24.0)/ DATA COEFF2 / (1.0,1.0), (1.0,3.0) / DATA COEFF3 / (0.0,0.0), (1.0,3.0) / DATA CHK1 / (4.0,2.0), (3.0,0.0), (-2.0,0.0), (2.0,0.0), & (0.0,-1.0), (-1.0,0.0), (0.0,1.0), (1.0,0.0) / !***FIRST EXECUTABLE STATEMENT CQRTST DATA CHK2 / (-2.0,-1.0) / if ( kprint >= 2) write (LUN, 90000) TOL = SQRT(R1MACH(4)) ! ! First test. ! ipass = 1 ! ! Check to see if test passed. ! call CPQR79 (8, COEFF1, ROOT, IERR, WORK) ITMP(1:7) = 0 ! ! Check for roots in any order. ! DO 30 I=1,7 DO 20 J=1,7 if ( ABS(ROOT(I)-CHK1(J)) <= TOL ) then ITMP(J) = 1 GOTO 30 end if 20 continue ! ! Check that we found all 7 roots. ! 30 continue ITEST(1) = 1 DO 40 I=1,7 ITEST(1) = ITEST(1)*ITMP(I) ! ! Print test results. ! 40 continue if ( KPRINT >= 3 .OR. (KPRINT>=2 .and. ITEST(1) == 0) ) then write (LUN, 90010) write (LUN, 90020) (J,COEFF1(J), J=1,9) write (LUN, 90030) write (LUN, 90040) (J,ROOT(J), J=1,7) end if if ( kprint >= 2 ) then call PASS (LUN, 1, ITEST(1)) ! ! Set up next problem. ! end if ! ! Check to see if test passed. ! call CPQR79 (1, COEFF2, ROOT, IERR, WORK) ITEST(2) = 1 ! ! Print test results for second test. ! if ( ABS(ROOT(1)-CHK2) > TOL) ITEST(2) = 0 if ( KPRINT >= 3 .OR. (KPRINT>=2 .and. ITEST(1) == 0) ) then write (LUN, 90050) write (LUN, 90010) write (LUN, 90020) (J,COEFF2(J), J=1,2) write (LUN, 90030) write (LUN, 90040) (J,ROOT(J), J=1,1) end if if ( kprint >= 2 ) then call PASS (LUN, 2, ITEST(2)) ! ! Trigger 2 error conditions ! end if call XGETF (KONTRL) if ( kprint <= 2 ) then call XSETF (0) else call XSETF (1) end if FATAL = .FALSE. call xerclr ! ! call CPQR79 with 0 degree polynomial. ! if ( kprint >= 3) write (LUN, 90060) call CPQR79 (0, COEFF2, ROOT, IERR, WORK) if ( NUMXER(NERR) /= 3 ) then FATAL = .TRUE. end if ! ! call CPQR79 with zero leading coefficient. ! call xerclr call CPQR79 (2, COEFF3, ROOT, IERR, WORK) if ( NUMXER(NERR) /= 2 ) then FATAL = .TRUE. end if ! call xerclr call XSETF (KONTRL) if ( FATAL ) then ipass = 0 if ( kprint >= 2 ) then write (LUN, 90070) end if else if ( kprint >= 3 ) then write (LUN, 90080) end if ! ! See if all tests passed. ! end if ! ipass = IPASS*ITEST(1)*ITEST(2) if ( ipass == 1 .and. kprint > 1) write (LUN,90100) if ( ipass == 0 .and. kprint /= 0) write (LUN,90110) ! return 90000 FORMAT ('1', /,' CPQR79 QUICK CHECK') 90010 FORMAT (/, ' CHECK REAL AND IMAGINARY PARTS OF ROOT' / & ' COEFFICIENTS') 90020 FORMAT (/ (I6, 3X, 1P, 2E22.14)) 90030 FORMAT (// 25X, 'TABLE of ROOTS' // & ' ROOT REAL PART', 12X, 'IMAG PART' / & ' NUMBER', 8X, 2(' of ZERO ', 12X)) 90040 FORMAT (I6, 3X, 1P, 2E22.14) 90050 FORMAT (/, ' TEST SUBSEQUENT RELATED CALL') 90060 FORMAT (// ' TRIGGER 2 ERROR CONDITIONS' //) 90070 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 90080 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED') 90100 FORMAT (/' **************CPQR79 PASSED ALL TESTS**************') 90110 FORMAT (/' **************CPQR79 FAILED SOME TESTS*************') end !! CSIQC !***PURPOSE Quick check for CSIFA, CSICO, CSISL and CSIDI. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS ! OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. ! THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C ! (THE SOLUTION VECTOR), AINV (INVERSE OF MATRIX A ), DC ! (DETERMINANT OF A ), AND RCND ( RCOND ) ARE ENTERED ! WITH DATA STATEMENTS. ! ! THE COMPUTED TEST RESULTS FOR X, RCOND, THE DETERMINANT, AND ! THE INVERSE ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. ! FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT ! DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH ! LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS ! PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. ! ! NO INPUT ARGUMENTS ARE REQUIRED. ! ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF ! ALL FAILURES DETECTED BY CSIQC. ! !***ROUTINES CALLED CSICO, CSIDI, CSIFA, CSISL !***REVISION HISTORY (YYMMDD) ! 801021 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if and cleaned up ! FORMATs. (RWC) !***END PROLOGUE CSIQC subroutine CSIQC (LUN, KPRINT, NERR) COMPLEX A(4,4),AT(5,4),B(4),BT(4),C(4),AINV(4,4),DET(2),DC(2), & Z(4),XA,XB REAL R,RCOND,RCND,DELX CHARACTER KPROG*19, KFAIL*39 integer LDA,N,IPVT(4),INFO,I,J,INDX,NERR DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(3.E0,2.E0),(1.E0,1.E0),(0.E0,-4.E0),(3.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA AINV/(.40000E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,.20000E0),(.40000E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(.30769E0,0.E0),(0.E0,1.E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,.07692E0),(.23077E0,0.E0)/ DATA DC/(6.5E0,0.E0),(1.0E0,0.E0)/ DATA KPROG/'SIFA SICO SISL SIDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE'/ ! DATA RCND/.58692E0/ !***FIRST EXECUTABLE STATEMENT CSIQC DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) LDA = 5 N = 4 ! ! FORM AT FOR CSIFA AND BT FOR CSISL, TEST CSIFA ! NERR = 0 DO 20 J=1,N BT(J) = B(J) AT(1:n,J) = A(1:n,J) 20 continue call CSIFA(AT,LDA,N,IPVT,INFO) if ( INFO /= 0 ) then write (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ! ! TEST CSISL ! end if call CSISL(AT,LDA,N,IPVT,BT) INDX = 0 DO 40 I=1,N if ( DELX(C(I),BT(I)) > .0001) INDX=INDX+1 ! 40 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ! ! FORM AT FOR CSICO, TEST CSICO ! end if DO 70 J=1,N DO 60 I=1,N AT(I,J) = A(I,J) 60 continue ! 70 continue call CSICO(AT,LDA,N,IPVT,RCOND,Z) R = ABS(RCND-RCOND) if ( R >= .0001 ) then write (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ! ! TEST CSIDI FOR JOB=11 ! end if call CSIDI(AT,LDA,N,IPVT,DET,Z,11) INDX = 0 DO 110 I=1,2 if ( DELX(DC(I),DET(I)) > .0001) INDX=INDX+1 ! 110 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ! end if INDX = 0 DO 140 I=1,N DO 130 J=1,N if ( DELX(AINV(I,J),AT(I,J)) > .0001) INDX=INDX+1 130 continue ! 140 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(33:39) NERR = NERR + 1 ! end if if ( KPRINT >= 2 .OR. NERR /= 0) write (LUN,200) NERR ! return 200 FORMAT(/' * CSIQC - TEST FOR CSIFA, CSICO, CSISL AND CSIDI FOUND ' & , I1, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) end !! CSPQC !***PURPOSE Quick check for CSPFA, CSPCO, CSPSL and CSPDI. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS ! OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. ! THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C ! (THE SOLUTION VECTOR), AINV (INVERSE OF MATRIX A ), DC ! (DETERMINANT OF A ), AND RCND ( RCOND ) ARE ENTERED ! WITH DATA STATEMENTS. ! ! THE COMPUTED TEST RESULTS FOR X, RCOND, THE DETERMINANT, AND ! THE INVERSE ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. ! FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT ! DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH ! LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS ! PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. ! ! NO INPUT ARGUMENTS ARE REQUIRED. ! ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF ! ALL FAILURES DETECTED BY CSPQC. ! !***ROUTINES CALLED CSPCO, CSPDI, CSPFA, CSPSL !***REVISION HISTORY (YYMMDD) ! 801021 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if and cleaned up ! FORMATs. (RWC) !***END PROLOGUE CSPQC subroutine CSPQC (LUN, KPRINT, NERR) COMPLEX AP(10),AT(10),B(4),BT(4),C(4),AINV(10),DET(2),DC(2), & Z(4),XA,XB REAL R,RCOND,RCND,DELX CHARACTER KPROG*19, KFAIL*39 integer N,IPVT(4),INFO,I,J,INDX,NERR DATA AP/(2.E0,0.E0),(0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(3.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(3.E0,2.E0),(1.E0,1.E0),(0.E0,-4.E0),(3.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA AINV/(.4E0,0.E0),(0.E0,.2E0),(.4E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(.30769E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,.07692E0),(.23077E0,0.E0)/ DATA DC/(6.5E0,0.E0),(1.0E0,0.E0)/ DATA KPROG/'SPFA SPCO SPSL SPDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE'/ ! DATA RCND/.58692E0/ !***FIRST EXECUTABLE STATEMENT CSPQC DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) N = 4 ! ! FORM AT FOR CSPFA AND BT FOR CSPSL, TEST CSPFA ! NERR = 0 BT(1:n) = B(1:n) DO 20 I=1,10 AT(I) = AP(I) ! 20 continue call CSPFA(AT,N,IPVT,INFO) if ( INFO /= 0 ) then write (LUN,201) KPROG(1:4),KFAIL(1:4) NERR = NERR + 1 ! ! TEST CSPSL ! end if call CSPSL(AT,N,IPVT,BT) INDX = 0 DO 40 I=1,N if ( DELX(C(I),BT(I)) > .0001) INDX=INDX+1 ! 40 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ! ! FORM AT FOR CSPCO, TEST CSPCO ! end if DO 60 I=1,10 AT(I) = AP(I) ! 60 continue call CSPCO(AT,N,IPVT,RCOND,Z) R = ABS(RCND-RCOND) if ( R >= .0001 ) then write (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ! ! TEST CSPDI FOR JOB=11 ! end if call CSPDI(AT,N,IPVT,DET,Z,11) INDX = 0 DO 110 I=1,2 if ( DELX(DC(I),DET(I)) > .0001) INDX=INDX+1 ! 110 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ! end if INDX = 0 DO 140 I=1,10 if ( DELX(AINV(I),AT(I)) > .0001) INDX=INDX+1 ! 140 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(33:39) NERR = NERR + 1 ! end if if ( KPRINT >= 2 .OR. NERR /= 0) write (LUN,200) NERR ! return 200 FORMAT(/' * CSPQC - TEST FOR CSPFA, CSPCO, CSPSL AND CSPDI FOUND ' & , I1, ' ERRORS.'/) 201 FORMAT (/'*** C', A, ' FAILURE - ERROR IN ', A) end !! CSVQC !***PURPOSE Quick check for CSVDC. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! THE RETURNED FLOATING POINT VALUES FROM CSVDC FOR ! S, E, U, AND V ARE COMPARED TO THEIR ! CORRESPONDING STORED PRE-COMPUTED VALUES (ENTERED ! WITH DATA STATEMENTS). FAILURE OF THE TEST OCCURS WHEN ! AGREEMENT TO 3 SIGNIFICANT DIGITS IS NOT ACHIEVED AND ! AN ERROR MESSAGE IS THEN PRINTED. ! ! THE RETURNED INTEGER VALUE OF INFO IS ALSO CHECKED. ! LACK OF AGREEMENT RESULTS IN AN ERROR MESSAGE. A SUMMARY ! LINE IS ALWAYS PRINTED. ! ! NO INPUT ARGUMENTS ARE REQUIRED. ON RETURN, NERR (INTEGER ! TYPE) CONTAINS THE TOTAL COUNT OF ALL FAILURES DETECTED. ! !***ROUTINES CALLED CSVDC !***REVISION HISTORY (YYMMDD) ! 801031 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if, moved an ARITHMETIC ! STATEMENT FUNCTION ahead of the FIRST EXECUTABLE STATEMENT ! record and cleaned up FORMATs. (RWC) !***END PROLOGUE CSVQC subroutine CSVQC (LUN, KPRINT, NERR) COMPLEX A(4,4),WORK(4),S(4),E(4),U(4,4),V(4,4) COMPLEX AT(5,4),SC(4),EC(4),UVC(4,4),X1,X2 integer LDX,N,P,LDU,LDV,JOB,INFO CHARACTER KFAIL*12 integer I,J,INDX(4) REAL DELX DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA KFAIL/'S E U V INFO'/ DATA SC/(4.61803E0,0.E0),(3.0E0,0.E0),(2.38197E0,0.E0),(1.E0,0.E0) & / DATA EC/(0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0)/ DATA UVC/(0.E0,0.E0),(0.E0,0.E0),(-.52573E0,0.E0),(0.E0,-.85065E0) & , & (.70711E0,0.E0),(0.E0,.70711E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(-.85065E0,0.E0),(0.E0,.52573E0), & ! (-.70711E0,0.E0),(0.E0,.70711E0),(0.E0,0.E0),(0.E0,0.E0)/ !***FIRST EXECUTABLE STATEMENT CSVQC DELX(X1,X2) = ABS(REAL(X1-X2))+ABS(AIMAG(X1-X2)) N = 4 P = 4 LDX = 5 LDU = 4 LDV = 4 NERR = 0 ! ! FORM AT ! JOB = 11 DO 20 J=1,N AT(1:n,J) = A(1:n,J) ! ! TEST CSVDC (S, E, U, V, INFO) ! 20 continue DO 30 I=1,4 INDX(I) = 0 ! 30 continue call CSVDC(AT,LDX,N,P,S,E,U,LDU,V,LDV,WORK,JOB,INFO) DO 50 J=1,N if ( DELX(S(J),SC(J)) > .0001) INDX(1) = INDX(1)+1 if ( DELX(E(J),EC(J)) > .0001) INDX(2) = INDX(2)+1 DO 40 I=1,N if ( DELX(U(I,J),UVC(I,J)) > .0001) INDX(3) = INDX(3)+1 if ( DELX(V(I,J),UVC(I,J)) > .0001) INDX(4) = INDX(4)+1 40 continue ! 50 continue DO 70 I=1,4 KONE=2*I-1 if ( INDX(I) /= 0 ) then write (LUN,201) KFAIL(KONE:KONE) NERR = NERR + 1 end if ! 70 continue if ( INFO /= 0 ) then write (LUN,201) KFAIL(9:12) NERR = NERR + 1 ! end if if ( KPRINT >= 2 .OR. NERR /= 0) write (LUN,200) NERR ! return 200 FORMAT (/' * CSVQC - TEST FOR CSVDC FOUND ', I1, ' ERRORS.'/) 201 FORMAT (/' *** CSVQC FAILURE - ERROR IN ', A) end !! CTRQC !***PURPOSE Quick check for CTRFA, CTRCO, CTRSL and CTRDI. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! LET A*X=B BE A COMPLEX LINEAR SYSTEM WHERE THE MATRIX A IS ! OF THE PROPER TYPE FOR THE LINPACK SUBROUTINES BEING TESTED. ! THE VALUES OF A AND B AND THE PRE-COMPUTED VALUES OF C ! (THE SOLUTION VECTOR), AINV (INVERSE OF MATRIX A ), DC ! (DETERMINANT OF A ), AND RCND ( RCOND ) ARE ENTERED ! WITH DATA STATEMENTS. ! ! THE COMPUTED TEST RESULTS FOR X, RCOND, THE DETERMINANT, AND ! THE INVERSE ARE COMPARED TO THE STORED PRE-COMPUTED VALUES. ! FAILURE OF THE TEST OCCURS WHEN AGREEMENT TO 3 SIGNIFICANT ! DIGITS IS NOT ACHIEVED AND AN ERROR MESSAGE INDICATING WHICH ! LINPACK SUBROUTINE FAILED AND WHICH QUANTITY WAS INVOLVED IS ! PRINTED. A SUMMARY LINE IS ALWAYS PRINTED. ! ! NO INPUT ARGUMENTS ARE REQUIRED. ! ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT OF ! ALL FAILURES DETECTED BY CTRQC. ! !***ROUTINES CALLED CTRCO, CTRDI, CTRSL !***REVISION HISTORY (YYMMDD) ! 801023 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if and cleaned up ! FORMATs. (RWC) !***END PROLOGUE CTRQC subroutine CTRQC (LUN, KPRINT, NERR) COMPLEX A(4,4),AT(5,4),B(4,2),BT(4),C(4),AINV(4,4,2),DET(2), & DC(2),Z(4),XA,XB REAL R,RCOND,RCND(2),DELX CHARACTER KPROG*19, KFAIL*39 integer LDA,N,INFO,I,J,INDX,NERR integer JOB,K,KK DATA A/(2.E0,0.E0),(0.E0,1.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,-1.E0),(2.E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(3.E0,0.E0),(0.E0,1.E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.E0),(4.E0,0.E0)/ DATA B/(2.E0,2.E0),(-1.E0,3.E0),(0.E0,-3.E0),(5.E0,0.E0), & (3.E0,2.E0),(0.E0,2.E0),(0.E0,-4.E0),(4.E0,0.E0)/ DATA C/(1.E0,1.E0),(0.E0,1.E0),(0.E0,-1.E0),(1.E0,0.E0)/ DATA AINV/(.50000E0,0.E0),(0.E0,-.25000E0),(0.E0,0.E0), & (0.E0,0.E0), & (0.E0,-1.00000E0),(.50000E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(.33333E0,0.E0),(0.E0,-.083333E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,-1.00000E0),(.25000E0,0.E0), & (.50000E0,0.E0),(0.E0,1.00000E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,.25000E0),(.50000E0,0.E0),(0.E0,0.E0),(0.E0,0.E0), & (0.E0,0.E0),(0.E0,0.E0),(.33333E0,0.E0),(0.E0,1.00000E0), & (0.E0,0.E0),(0.E0,0.E0),(0.E0,.083333E0),(.25000E0,0.E0)/ DATA DC/(4.8E0,0.E0),(1.0E0,0.E0)/ DATA KPROG/'TRFA TRCO TRSL TRDI'/ DATA KFAIL/'INFO RCOND SOLUTION DETERMINANT INVERSE'/ ! DATA RCND/.45695E0,.37047E0/ !***FIRST EXECUTABLE STATEMENT CTRQC DELX(XA,XB)=ABS(REAL(XA-XB))+ABS(AIMAG(XA-XB)) LDA = 5 N = 4 ! ! K=1 FOR LOWER, K=2 FOR UPPER ! NERR = 0 ! ! FORM AT FOR CTRCO AND BT FOR CTRSL, TEST CTRCO ! DO 160 K=1,2 DO 20 J=1,N BT(J) = B(J,K) DO 10 I=1,N AT(I,J) = A(I,J) 10 continue ! 20 continue JOB = K - 1 call CTRCO(AT,LDA,N,RCOND,Z,JOB) R = ABS(RCND(K)-RCOND) if ( R >= .0001 ) then write (LUN,201) KPROG(6:9),KFAIL(6:10) NERR = NERR + 1 ! ! TEST CTRSL FOR JOB= 0 OR 1 ! end if call CTRSL(AT,LDA,N,BT,JOB,INFO) if ( INFO /= 0 ) then write (LUN,201) KPROG(11:14),KFAIL(1:4) NERR = NERR + 1 ! end if INDX = 0 DO 50 I=1,N if ( DELX(C(I),BT(I)) > .0001) INDX=INDX+1 ! 50 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ! ! FORM BT FOR CTRSL ! end if KK = 3 - K DO 70 J=1,N BT(J) = B(J,KK) ! ! TEST CTRSL FOR JOB EQUAL TO 10 OR 11 ! 70 continue JOB = 9 + K call CTRSL(AT,LDA,N,BT,JOB,INFO) if ( INFO /= 0 ) then write (LUN,201) KPROG(11:14),KFAIL(1:4) NERR = NERR + 1 ! end if INDX = 0 DO 90 I=1,N if ( DELX(C(I),BT(I)) > .0001) INDX=INDX+1 ! 90 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(11:14),KFAIL(12:19) NERR = NERR + 1 ! ! TEST CTRDI FOR JOB= 110 OR 111 ! end if JOB = 109 + K call CTRDI(AT,LDA,N,DET,JOB,INFO) if ( INFO /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(1:4) NERR = NERR + 1 ! end if INDX = 0 DO 110 I=1,2 if ( DELX(DC(I),DET(I)) > .0001) INDX=INDX+1 ! 110 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(21:31) NERR = NERR + 1 ! end if INDX = 0 DO 140 I=1,N DO 130 J=1,N if ( DELX(AINV(I,J,K),AT(I,J)) > .0001) INDX=INDX+1 130 continue ! 140 continue if ( INDX /= 0 ) then write (LUN,201) KPROG(16:19),KFAIL(33:39) NERR = NERR + 1 end if ! 160 continue if ( KPRINT >= 2 .OR. NERR /= 0) write (LUN,200) NERR ! return 200 FORMAT(/' * CTRQC - TEST FOR CTRCO, CTRSL AND CTRDI FOUND ' & , I2, ' ERRORS.'/) 201 FORMAT (/' *** C', A, ' FAILURE - ERROR IN ', A) end !! DAVNTS !***PURPOSE Quick check for DAVINT. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (AVNTST-S, DAVNTS-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED d1mach, DAVINT, 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 d1mach(3) to d1mach(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 DAVNTS subroutine DAVNTS (LUN, KPRINT, IPASS) double precision d1mach integer I, IERR, IPASS, KPRINT, LUN, N double precision A, ANS, B, DEL, RN1, SQB, TOL, TOL1, X(501), & XINT, Y(501) !***FIRST EXECUTABLE STATEMENT DAVNTS LOGICAL FATAL if ( kprint >= 2) write (LUN,9000) ipass = 1 TOL = max ( .0001D0,SQRT(d1mach(4))) ! ! Perform first accuracy test. ! TOL1 = 1.0D-2*TOL A = 0.0D0 B = 5.0D0 XINT = EXP(5.0D0) - 1.0D0 N = 500 RN1 = N - 1 SQB = SQRT(B) DEL = 0.4D0*(B-A)/(N-1) DO 100 I = 1,N X(I) = SQB*SQRT(A+(I-1)*(B-A)/RN1) + DEL Y(I) = EXP(X(I)) 100 continue ! ! See if test was passed. ! call DAVINT (X, Y, N, A, B, ANS, IERR) if ( ABS(ANS-XINT) > TOL ) then ipass = 0 if ( kprint >= 3) write (LUN,9010) IERR, ANS, XINT ! ! Perform second accuracy test. ! end if X(1) = 0.0D0 X(2) = 5.0D0 Y(1) = 1.0D0 Y(2) = 0.5D0 A = -0.5D0 B = 0.5D0 XINT = 1.0D0 ! ! See if test was passed. ! call DAVINT (X, Y, 2, A, B, ANS, IERR) if ( ABS(ANS-XINT) > TOL1 ) then ipass = 0 if ( kprint >= 3) write (LUN,9010) IERR, ANS, XINT ! ! Send message indicating passage or failure of tests. ! end if if ( kprint >= 2 ) then if ( ipass == 1 ) then if ( kprint >= 3) write (LUN,9020) else write (LUN,9030) end if ! ! Test error returns. ! 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 ) then write (LUN,9040) end if DO 110 I = 1,20 X(I) = (I-1)/19.0D0 - 0.01D0 if ( I /= 1) Y(I) = X(I)/(EXP(X(I))-1.0) ! ! Test IERR = 1 error return. ! 110 continue Y(1) = 1.0D0 call DAVINT (X, Y, 20, 0.0D0, 1.0D0, ANS, IERR) if ( IERR /= 1 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 3) write (LUN,9060) IERR, 1 end if ! ! Test IERR = 2 error return. ! call xerclr call DAVINT (X, Y, 20, 1.0D0, 0.0D0, ANS, IERR) if ( IERR /= 2 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 3) write (LUN,9060) IERR, 2 end if if ( ANS /= 0.0D0 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 3) write (LUN,9070) end if ! ! Test IERR = 5 error return. ! call xerclr call DAVINT (X, Y, 1, 0.0D0, 1.0D0, ANS, IERR) if ( IERR /= 5 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 3) write (LUN,9060) IERR, 5 end if if ( ANS /= 0.0D0 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 3) write (LUN,9070) end if ! ! Test IERR = 4 error return. ! call xerclr X(1) = 1.0D0/19.0D0 X(2) = 0.0D0 call DAVINT (X, Y, 20, 0.0D0, 1.0D0, ANS, IERR) if ( IERR /= 4 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 3) write (LUN,9060) IERR, 4 end if if ( ANS /= 0.0D0 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 3) write (LUN,9070) end if ! ! Test IERR = 3 error return. ! call xerclr X(1) = 0.0D0 X(2) = 1.0D0/19.0D0 call DAVINT (X, Y, 20, 0.0D0, .01D0, ANS, IERR) if ( IERR /= 3 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 3) write (LUN,9060) IERR, 3 end if if ( ANS /= 0.0D0 ) 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 ! ! Write PASS/FAIL message. ! end if if ( ipass == 1 .and. KPRINT >= 3) write (LUN,9100) if ( ipass == 0 .and. KPRINT >= 2) write (LUN,9110) return 9000 FORMAT ('1' / ' DAVINT Quick Check') 9010 FORMAT (/' FAILED ACCURACY TEST' / & ' IERR=', I2, 5X, 'COMPUTED ANS=', E20.11 / 14X, & 'CORRECT ANS=', D20.11, 5X, 'REQUESTED ERR=', D10.2) 9020 FORMAT (/ ' DAVINT passed both accuracy tests.') 9030 FORMAT (/ ' DAVINT failed at least one accuracy test.') 9040 FORMAT (/ ' Test error returns from DAVINT' / & ' 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 (/' ***************DAVINT PASSED ALL TESTS***************') 9110 FORMAT (/' ***************DAVINT FAILED SOME TESTS**************') end !! DBEG !***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 DBEG ! .. Scalar Arguments .. double precision FUNCTION DBEG (RESET) ! .. Local Scalars .. LOGICAL RESET ! .. Save statement .. integer I, IC, MI ! .. Intrinsic Functions .. SAVE I, IC, MI !***FIRST EXECUTABLE STATEMENT DBEG INTRINSIC DBLE ! Initialize local variables. if ( RESET ) then MI = 891 I = 7 IC = 0 RESET = .FALSE. ! ! The sequence of values of I is bounded between 1 and 999. ! If initial I = 1,2,3,6,7 or 9, the period will be 50. ! If initial I = 4 or 8, the period will be 25. ! If initial I = 5, the period will be 10. ! IC is used to break up the period by skipping 1 value of I in 6. ! end if IC = IC + 1 10 I = I*MI I = I - 1000*( I/1000 ) if ( IC >= 5 ) then IC = 0 GO TO 10 end if DBEG = DBLE( I - 500 )/1001.0D0 ! ! End of DBEG. ! return end !! DBIKCK !***PURPOSE Quick check for DBESI and DBESK. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (BIKCK-S, DBIKCK-D) !***KEYWORDS QUICK CHECK !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! DBIKCK is a quick check routine for DBESI and DBESK. The main loops ! evaluate the Wronskian and test the error. Underflow and overflow ! diagnostics are checked in addition to illegal arguments. ! !***ROUTINES CALLED d1mach, DBESI, DBESK, NUMXER, 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) ! 901205 Changed usage of d1mach(3) to d1mach(4). (RWC) ! 910121 Editorial Changes. (RWC) ! 910501 Added TYPE record. (WRB) ! 910708 Code revised to test error returns for all values of ! KPRINT. (WRB) ! 910801 Editorial changes, some restructing and modifications to ! obtain more information when there is failure of the ! Wronskian. (WRB) !***END PROLOGUE DBIKCK subroutine DBIKCK (LUN, KPRINT, IPASS) integer I, IPASS, IX, K, KODE, KONTRL, LUN, M, N, NERR, NU, NW, NY double precision ALP, DEL, ER, FNU, FNUP, RX, TOL, X double precision FN(3), W(5), XX(5), Y(5) double precision d1mach !***FIRST EXECUTABLE STATEMENT DBIKCK LOGICAL FATAL ! if ( kprint >= 2) write (LUN,90000) ipass = 1 XX(1) = 0.49D0 XX(2) = 1.3D0 XX(3) = 5.3D0 XX(4) = 13.3D0 XX(5) = 21.3D0 FN(1) = 0.095D0 FN(2) = 0.70D0 FN(3) = 0.0D0 TOL = max ( 500.0D0*d1mach(4), 7.1D-12) 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.0D0/X call DBESI(X, FNU, KODE, N, Y, NY) if ( NY /= 0) GO TO 20 call DBESK(X, FNU, KODE, N, W, NW) if ( NW /= 0) GO TO 20 FNUP = FNU + N call DBESI(X,FNUP,KODE,1,Y(N+1),NY) if ( NY /= 0) GO TO 20 call DBESK(X,FNUP,KODE,1,W(N+1),NW) if ( NW /= 0) GO TO 20 DO 10 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 10 continue 20 continue 30 continue 40 continue 50 continue ! ! Check small values of X and order ! 60 continue N = 2 FNU = 1.0D0 X = d1mach(4) DO 80 I=1,3 DO 70 KODE=1,2 call DBESI(X, FNU, KODE, N, Y, NY) call DBESK(X, FNU, KODE, N, W, NW) ER = Y(2)*W(1) + W(2)*Y(1) - 1.0D0/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 = d1mach(4)/100.0D0 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.0D0+DEL DO 75 N=1,2 X = 20.0D0 + DEL DO 71 I=1,5 RX = 1.0D0/X call DBESI(X, FNU, KODE, N, Y, NY) if ( NY /= 0) GO TO 71 call DBESK(X, FNU, KODE, N, W, NW) if ( NW /= 0) GO TO 71 if ( N == 1 ) then FNUP = FNU + 1.0D0 call DBESI(X,FNUP,KODE,1,Y(2),NY) if ( NY /= 0) GO TO 71 call DBESK(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.0D0 71 continue 75 continue ! ! Check underflow flags ! 76 continue 760 X = d1mach(1)*10.0D0 ALP = 12.3D0 N = 3 call DBESI(X, ALP, 1, N, Y, NY) if ( NY /= 3 ) then ipass = 0 if ( KPRINT >= 2) write (LUN,90040) ! end if X = LOG(d1mach(2)/10.0D0) + 20.0D0 ALP = 1.3D0 N = 3 call DBESK(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.0D0 XX(2) = 1.0D0 XX(3) = 1.0D0 ! ! Illegal arguments ! XX(4) = 1.0D0 DO 90 I=1,4 XX(I) = -XX(I) K = INT(XX(3)) N = INT(XX(4)) call DBESI(XX(1), XX(2), K, N, Y, NY) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr call DBESK(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 ! 90 continue X = LOG(d1mach(2)/10.0D0) + 20.0D0 N = 3 ALP = 2.3D0 call DBESI(X, ALP, 1, N, Y, NY) if ( NUMXER(NERR) /= 6 ) then ipass = 0 FATAL = .TRUE. end if ! call xerclr X = d1mach(1)*10.0D0 call DBESK(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 DBESI AND DBESK' //) 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 DBESI UNDERFLOW TEST' /) 90050 FORMAT (/ ' ERROR IN DBESK 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 (/' *********DBESI AND DBESK PASSED ALL TESTS***********') 90110 FORMAT (/' *********DBESI OR DBESK FAILED SOME TESTS***********') end !! DBJYCK !***PURPOSE Quick check for DBESJ and DBESY. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (BJYCK-S, DBJYCK-D) !***KEYWORDS QUICK CHECK !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! DBJYCK is a quick check routine for DBESJ and DBESY. The main loops ! evaluate the Wronskian and test the error. Underflow and overflow ! diagnostics are checked in addition to illegal arguments. ! !***ROUTINES CALLED d1mach, DBESJ, DBESY, NUMXER, 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) ! 901205 Changed usage of d1mach(3) to d1mach(4). (RWC) ! 910121 Editorial Changes. (RWC) ! 910501 Added TYPE record. (WRB) ! 910708 Code revised to test error returns for all values of ! KPRINT. (WRB) ! 910801 Editorial changes, some restructing and modifications to ! obtain more information when there is failure of the ! Wronskian. (WRB) !***END PROLOGUE DBJYCK subroutine DBJYCK (LUN, KPRINT, IPASS) integer I, IPASS, IX, K, KONTRL, LUN, M, N, NERR, NU, NY double precision ALP, DEL, ER, FNU, FNUP, RHPI, RX, TOL, X double precision FN(3), W(5), XX(5), Y(5) double precision d1mach !***FIRST EXECUTABLE STATEMENT DBJYCK LOGICAL FATAL ! if ( KPRINT >= 2) write (LUN,90000) ipass = 1 RHPI = 0.5D0/ATAN(1.0D0) XX(1) = 0.49D0 XX(2) = 1.3D0 XX(3) = 5.3D0 XX(4) = 13.3D0 XX(5) = 21.3D0 FN(1) = 0.095D0 FN(2) = 0.70D0 FN(3) = 0.0D0 TOL = max ( 500.0D0*d1mach(4), 7.1D-12) 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 DBESJ(X, FNU, N, Y, NY) if ( NY /= 0) GO TO 20 call DBESY(X, FNU, N, W) FNUP = FNU + N call DBESJ(X,FNUP,1,Y(N+1),NY) if ( NY /= 0) GO TO 20 call DBESY(X,FNUP,1,W(N+1)) DO 10 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 10 continue 20 continue 30 continue 40 continue ! ! Check small values of X and order ! 50 continue N = 2 FNU = 1.0D0 X = d1mach(4)/5.0D0 RX = RHPI/X DO I=1,3 call DBESJ(X, FNU, N, Y, NY) call DBESY(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) exit end if FNU = d1mach(4)/100.0D0 X = XX(2*I-1) RX = RHPI/X end do ! ! Check large values of X and order ! 600 DO 76 K=1,2 DEL = 30*(K-1) FNU = 70.0D0+DEL DO 75 N=1,2 X = 50.0D0 + DEL DO 70 I=1,5 RX = RHPI/X call DBESJ(X, FNU, N, Y, NY) if ( NY /= 0) GO TO 70 call DBESY(X, FNU, N, W) if ( N == 1 ) then FNUP = FNU + 1.0D0 call DBESJ(X,FNUP,1,Y(2),NY) if ( NY /= 0) GO TO 70 call DBESY(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.0D0 70 continue 75 continue ! ! Check underflow flags ! 76 continue 800 X = d1mach(1)*10.0D0 ALP = 12.3D0 N = 3 call DBESJ(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.0D0 XX(2) = 1.0D0 ! ! Illegal arguments ! XX(3) = 1.0D0 DO I=1,3 XX(I) = -XX(I) N = INT(XX(3)) call DBESJ(XX(1), XX(2), N, Y, NY) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr call DBESY(XX(1), XX(2), N, W) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr XX(I) = -XX(I) end do ! ! Trigger overflow ! X = d1mach(1)*10.0D0 N = 3 ALP = 2.3D0 call DBESY(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 DBESJ AND DBESY' //) 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 DBESJ 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 (/' *********DBESJ AND DBESY PASSED ALL TESTS*********') 90110 FORMAT (/' *********DBESJ OR DBESY FAILED SOME TESTS*********') end !! DBLAT2 !***PURPOSE Driver for testing Level 2 BLAS double precision ! subroutines. !***LIBRARY SLATEC (BLAS) !***CATEGORY A3B !***TYPE DOUBLE PRECISION (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 DOUBLE 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 DCHK12, DCHK22, DCHK32, DCHK42, DCHK52, DCHK62, ! DCHKE2, DMVCH, LDE, 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 DBLAT2 ! .. Parameters .. subroutine DBLAT2 (NOUT, KPRINT, IPASS) integer NSUBS PARAMETER ( NSUBS = 16) double precision ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) integer NMAX, INCMAX ! .. Scalar Arguments .. PARAMETER ( NMAX = 65, INCMAX = 2 ) ! .. Local Scalars .. integer IPASS, KPRINT double precision 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 double precision A( NMAX, NMAX ), AA( NMAX*NMAX ), & ALF( NALF ), AS( NMAX*NMAX ), BET( NBET ), & G( NMAX ), X( NMAX ), XS( NMAX*INCMAX ), & XX( NMAX*INCMAX ), Y( NMAX ), & YS( NMAX*INCMAX ), YT( NMAX ), & YY( NMAX*INCMAX ), Z( 2*NMAX ) integer IDIM( NIDIM ), INC( NINC ), KB( NKB ) LOGICAL LTEST( NSUBS ) ! .. External Functions .. CHARACTER*6 SNAMES( NSUBS ) REAL R1MACH LOGICAL LDE ! .. External Subroutines .. EXTERNAL LDE, R1MACH EXTERNAL DCHK12, DCHK22, DCHK32, DCHK42, DCHK52, DCHK62, & ! .. Intrinsic Functions .. DCHKE2, DMVCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN DATA SNAMES/'DGEMV ', 'DGBMV ', 'DSYMV ', 'DSBMV ', & 'DSPMV ', 'DTRMV ', 'DTBMV ', 'DTPMV ', & 'DTRSV ', 'DTBSV ', 'DTPSV ', 'DGER ', & 'DSYR ', 'DSPR ', 'DSYR2 ', 'DSPR2 '/ DATA IDIM/0,1,2,3,5,9/ DATA KB/0,1,2,4/ DATA INC/1,2,-1,-2/ DATA ALF/0.0,1.0,0.7/ !***FIRST EXECUTABLE STATEMENT DBLAT2 ! Set the flag that indicates whether error exits are to be tested. DATA BET/0.0,1.0,0.9/ ! Set the threshold value of the test ratio TSTERR = .TRUE. ! ! Set ipass to 1 assuming it 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 DO 40 I = 1, NSUBS LTEST( I ) = .TRUE. ! ! Set EPS (the machine precision). ! 40 continue ! ! Check the reliability of DMVCH using exact data. ! EPS = R1MACH (4) N = min ( 32, NMAX ) DO 120 J = 1, N DO 110 I = 1, N A( I, J ) = max ( I - J + 1, 0 ) 110 continue X( J ) = J Y( J ) = ZERO 120 continue 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 DMVCH YT holds ! the result computed by DMVCH. 130 continue TRANS = 'N' FTL = .FALSE. call DMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, & YY, EPS, ERR, FTL, NOUT, .TRUE., kprint ) SAME = LDE( YY, YT, N ) if ( .NOT.SAME.OR.ERR /= ZERO ) then ipass = 0 if ( kprint >= 2 ) then write ( NOUT, FMT = 9985 )TRANS, SAME, ERR end if end if TRANS = 'T' FTL = .FALSE. call DMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, & YY, EPS, ERR, FTL, NOUT, .TRUE., kprint ) SAME = LDE( YY, YT, N ) if ( .NOT.SAME.OR.ERR /= ZERO ) 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 DCHKE2(ISNUM, SNAMES( ISNUM ), NOUT, KPRINT, FTL1) ! Test computations. end if call xerclr FTL2 = .FALSE. GO TO ( 140, 140, 150, 150, 150, 160, 160, & 160, 160, 160, 160, 170, 180, 180, & ! Test DGEMV, 01, and DGBMV, 02. 190, 190 )ISNUM 140 call DCHK12( 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 DSYMV, 03, DSBMV, 04, and DSPMV, 05. GO TO 200 150 call DCHK22( 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 DTRMV, 06, DTBMV, 07, DTPMV, 08, ! DTRSV, 09, DTBSV, 10, and DTPSV, 11. GO TO 200 160 call DCHK32( 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 DGER, 12. GO TO 200 170 call DCHK42( 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 DSYR, 13, and DSPR, 14. GO TO 200 180 call DCHK52( 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 DSYR2, 15, and DSPR2, 16. GO TO 200 190 call DCHK62( 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 DOUBLE PRECISION 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 ', 7F6.1 ) 9988 FORMAT( ' FOR BETA ', 7F6.1 ) 9985 FORMAT( ' ERROR IN DMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', & 'ATED WRONGLY.', /' DMVCH 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 DBLAT2. ! 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) end !! DBLAT3 !***PURPOSE Driver for testing Level 3 BLAS double precision ! subroutines. !***LIBRARY SLATEC (BLAS) !***CATEGORY A3B !***TYPE DOUBLE PRECISION (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 DOUBLE 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 DCHK13, DCHK23, DCHK33, DCHK43, DCHK53, DCHKE3, ! DMMCH, LDE, 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 DBLAT3 ! .. Parameters .. subroutine DBLAT3 (NOUT, KPRINT, IPASS) integer NSUBS PARAMETER ( NSUBS = 6) double precision ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) integer NMAX ! .. Scalar Arguments .. PARAMETER ( NMAX = 65) ! .. Local Scalars .. integer IPASS, KPRINT double precision 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 double precision AB( NMAX, 2*NMAX ), AA( NMAX*NMAX ), & ALF( NALF ), AS( NMAX*NMAX ), BET( NBET ), & G( NMAX ), BB( NMAX*NMAX ), & BS( NMAX*NMAX ), C( NMAX, NMAX ), & CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), & W( 2*NMAX ) integer IDIM( NIDIM ) LOGICAL LTEST( NSUBS ) ! .. External Functions .. CHARACTER*6 SNAMES( NSUBS ) REAL R1MACH LOGICAL LDE ! .. External Subroutines .. EXTERNAL LDE, R1MACH EXTERNAL DCHK13, DCHK23, DCHK33, DCHK43, DCHK53, & ! .. Intrinsic Functions .. DCHKE3, DMMCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN DATA SNAMES/'DGEMM ', 'DSYMM ', 'DTRMM ', 'DTRSM ', & 'DSYRK ', 'DSYR2K'/ DATA IDIM/0,1,2,3,5,9/ DATA ALF/0.0,1.0,0.7/ !***FIRST EXECUTABLE STATEMENT DBLAT3 ! Set the flag that indicates whether error exits are to be tested. DATA BET/0.0,1.0,1.3/ ! Set the threshold value of the test ratio TSTERR = .TRUE. ! ! Set ipass to 1 assuming it 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 20 I = 1, NSUBS LTEST( I ) = .TRUE. ! ! Set EPS (the machine precision). ! 20 continue ! ! Check the reliability of DMMCH using exact data. ! EPS = R1MACH (4) N = min ( 32, NMAX ) DO 100 J = 1, N DO 90 I = 1, N AB( I, J ) = max ( I - J + 1, 0 ) 90 continue AB( J, NMAX + 1 ) = J AB( 1, NMAX + J ) = J C( J, 1 ) = ZERO 100 continue 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 DMMCH CT holds ! the result computed by DMMCH. 110 continue TRANSA = 'N' TRANSB = 'N' FTL = .FALSE. call DMMCH( 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 = LDE( CC, CT, N ) if ( .NOT.SAME.OR.ERR /= ZERO ) then ipass = 0 if ( kprint >= 2 ) then write ( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR end if end if TRANSB = 'T' FTL = .FALSE. call DMMCH( 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 = LDE( CC, CT, N ) if ( .NOT.SAME.OR.ERR /= ZERO ) 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 = 'T' TRANSB = 'N' FTL = .FALSE. call DMMCH( 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 = LDE( CC, CT, N ) if ( .NOT.SAME.OR.ERR /= ZERO ) then ipass = 0 if ( kprint >= 2 ) then write ( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR end if end if TRANSB = 'T' FTL = .FALSE. call DMMCH( 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 = LDE( CC, CT, N ) if ( .NOT.SAME.OR.ERR /= ZERO ) 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 DCHKE3(ISNUM, SNAMES( ISNUM ), NOUT, KPRINT, FTL1) ! Test computations. end if FTL2 = .FALSE. call xerclr ! Test DGEMM, 01. GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM 140 call DCHK13( 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 DSYMM, 02. GO TO 190 150 call DCHK23( 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 DTRMM, 03, DTRSM, 04. GO TO 190 160 call DCHK33( 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 DSYRK, 05. GO TO 190 170 call DCHK43( 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 DSYR2K, 06. GO TO 190 180 call DCHK53( 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 DOUBLE PRECISION LEVEL 3 BLAS', //' THE F', & 'OLLOWING PARAMETER VALUES WILL BE USED:' ) 9994 FORMAT( ' FOR N ', 9I6 ) 9993 FORMAT( ' FOR ALPHA ', 7F6.1 ) 9992 FORMAT( ' FOR BETA ', 7F6.1 ) 9989 FORMAT( ' ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', & 'ATED WRONGLY.', /' DMMCH 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 DBLAT3. ! 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) end !! DBOCQX !***PURPOSE Quick check for DBOCLS. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SBOCQX-S, DBOCQX-D) !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! MINIMAL TEST DRIVER FOR DBOCLS, BOUNDED CONSTRAINED LEAST ! SQUARES SOLVER. DELIVERS THE VALUE IPASS=1 IF 8 TESTS WERE ! PASSED. DELIVER THE VALUE IPASS=0 IF ANY ONE OF THEM FAILED. ! ! RUN FOUR BOUNDED LEAST SQUARES PROBLEMS THAT COME FROM THE ! DIPLOME WORK OF P. ZIMMERMANN. ! !***ROUTINES CALLED d1mach, DBOCLS, DBOLS, DCOPY, DNRM2 !***REVISION HISTORY (YYMMDD) ! 850310 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Added PASS/FAIL message. (RWC) !***END PROLOGUE DBOCQX subroutine DBOCQX (LUN, KPRINT, IPASS) IMPLICIT DOUBLE PRECISION (A-H,O-Z) double precision & D(6,5),W(11,11),BL(5,2),BU(5,2),X(30),RW(55),XTRUE(9) double precision C(5,5) double precision BL1(10),BU1(10) integer IND(10),IW(20),IOPT(40) double precision RHS(6,2) ! CHARACTER*4 MSG DATA ((C(I,J),I=1,5),J=1,5)/1.D0,10.D0,4.D0,8.D0,1.D0,1.D0,10.D0, & 2.D0,-1.D0,1.D0,1.D0,-3.D0,-3.D0,2.D0,1.D0,1.D0,5.D0,5.D0, & 5.D0,1.D0,1.D0,4.D0,-1.D0,-3.D0,1.D0/ DATA ((D(I,J),I=1,6),J=1,5)/-74.D0,14.D0,66.D0,-12.D0,3.D0,4.D0, & 80.D0,-69.D0,-72.D0,66.D0,8.D0,-12.D0,18.D0,21.D0,-5.D0, & -30.D0,-7.D0,4.D0,-11.D0,28.D0,7.D0,-23.D0,-4.D0,4.D0,-4.D0, & 0.D0,1.D0,3.D0,1.D0,0.D0/ DATA ((BL(I,J),I=1,5),J=1,2)/1.D0,0.D0,-1.D0,1.D0,-4.D0,-1.D0, & 0.D0,-3.D0,1.D0,-6.D0/ DATA ((BU(I,J),I=1,5),J=1,2)/3.D0,2.D0,1.D0,3.D0,-2.D0,3.D0,4.D0, & 1.D0,5.D0,-2.D0/ DATA ((RHS(I,J),I=1,6),J=1,2)/51.D0,-61.D0,-56.D0,69.D0,10.D0, & -12.D0,-5.D0,-9.D0,708.D0,4165.D0,-13266.D0,8409.D0/ DATA (XTRUE(J),J=1,9)/1.D0,2.D0,-1.D0,3.D0,-4.D0,1.D0,32.D0,30.D0, & !***FIRST EXECUTABLE STATEMENT DBOCQX 31.D0/ MDW = 11 MROWS = 6 NCOLS = 5 MCON = 4 IOPT(1) = 99 ipass = 1 ! ITEST = 0 ! if ( KPRINT >= 2) write (LUN, 99998) DO 50 IB = 1,2 ! ! TRANSFER DATA TO WORKING ARRAY W(*,*). ! DO 40 IRHS = 1,2 DO 10 J = 1,NCOLS call DCOPY(MROWS,D(1,J),1,W(1,J),1) ! 10 continue ! ! SET BOUND INDICATOR FLAGS. ! call DCOPY(MROWS,RHS(1,IRHS),1,W(1,NCOLS+1),1) DO 20 J = 1,NCOLS IND(J) = 3 ! 20 continue call DBOLS(W,MDW,MROWS,NCOLS,BL(1,IB),BU(1,IB),IND,IOPT,X, & RNORM,MODE,RW,IW) DO 30 J = 1,NCOLS X(J) = X(J) - XTRUE(J) ! 30 continue SR = DNRM2(NCOLS,X,1) MPASS = 1 if ( SR > 10.D2*SQRT(d1mach(4))) MPASS = 0 ipass = IPASS*MPASS if ( KPRINT >= 2 ) then MSG = 'PASS' if ( MPASS == 0) MSG = 'FAIL' ITEST = ITEST + 1 write (LUN, 99999) ITEST, IB, IRHS, SR, MSG end if 40 continue ! ! RUN STOER'S PROBLEM FROM 1971 SIAM J. N. ANAL. PAPER. ! 50 continue DO 90 IB = 1,2 DO 80 IRHS = 1,2 call DCOPY(11*10,0.D0,0,W,1) call DCOPY(NCOLS,BL(1,IB),1,BL1,1) call DCOPY(NCOLS,BU(1,IB),1,BU1,1) IND(NCOLS+1) = 2 IND(NCOLS+2) = 1 IND(NCOLS+3) = 2 IND(NCOLS+4) = 3 BU1(NCOLS+1) = 5. BL1(NCOLS+2) = 20. BU1(NCOLS+3) = 30. BL1(NCOLS+4) = 11. BU1(NCOLS+4) = 40. DO 60 J = 1,NCOLS call DCOPY(MCON,C(1,J),1,W(1,J),1) call DCOPY(MROWS,D(1,J),1,W(MCON+1,J),1) ! 60 continue ! ! CHECK LENGTHS OF REQD. ARRAYS. ! call DCOPY(MROWS,RHS(1,IRHS),1,W(MCON+1,NCOLS+1),1) IOPT(01) = 2 IOPT(02) = 11 IOPT(03) = 11 IOPT(04) = 10 IOPT(05) = 30 IOPT(06) = 55 IOPT(07) = 20 IOPT(08) = 40 IOPT(09) = 99 call DBOCLS(W,MDW,MCON,MROWS,NCOLS,BL1,BU1,IND,IOPT,X, & RNORMC,RNORM,MODE,RW,IW) DO 70 J = 1,NCOLS + MCON X(J) = X(J) - XTRUE(J) ! 70 continue SR = DNRM2(NCOLS+MCON,X,1) MPASS = 1 if ( SR > 10.D2*SQRT(d1mach(4))) MPASS = 0 ipass = IPASS*MPASS if ( KPRINT >= 2 ) then MSG = 'PASS' if ( MPASS == 0) MSG = 'FAIL' ITEST = ITEST + 1 write (LUN, 99999) ITEST, IB, IRHS, SR, MSG end if 80 continue ! ! HERE THE VALUE OF IPASS=1 SAYS THAT DBOCLS HAS PASSED ITS TESTS. ! THE VALUE OF IPASS=0 SAYS THAT DBOCLS HAS NOT PASSED. ! 90 continue if ( KPRINT >= 3) & write (LUN,'('' ipass VALUE. (A 1 IS GOOD, 0 IS BAD.)'',I4)')IPASS if ( KPRINT >= 2 .and. ipass == 0) WRITE(LUN,10789) ! return 10789 FORMAT (' ERROR IN DBOCLS OR DBOLS') 99998 FORMAT (' TEST IB IRHS SR') 99999 FORMAT (3I5, 1P,E20.6, ' TEST ', A, 'ED.') end !! DBSPCK !***PURPOSE Quick check for the B-Spline package. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (BSPCK-S, DBSPCK-D) !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! DBSPCK 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 DBFQAD, DBINT4, DBINTK, DBNFAC, ! DBNSLV, DBSGQ8, DBSPDR, DBSPEV, DBSPPP, DBSPVD, DBSPVN, DBSQAD, ! DBVALU, DINTRV, DPFQAD, DPPGQ8, DPPQAD and DPPVAL. ! !***ROUTINES CALLED d1mach, DBFQAD, DBINT4, DBINTK, DBSPDR, DBSPEV, ! DBSPPP, DBSPVD, DBSPVN, DBSQAD, DBVALU, DFB, ! DINTRV, DPFQAD, DPPQAD, DPPVAL !***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 DBSPCK ! .. Scalar Arguments .. subroutine DBSPCK (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN double precision 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 double precision ADif ( 52), BC(13), C(4, 10), CC(4, 4), Q(3), & ! .. External Functions .. QQ(77), QSAVE(2), SV(4), T(17), W(65), X(11), XI(11), Y(11) double precision d1mach, DBVALU, DFB, DPPVAL ! .. External Subroutines .. integer NUMXER EXTERNAL DBFQAD, DBINT4, DBINTK, DBSPDR, DBSPEV, DBSPPP, DBSPVD, & ! .. Intrinsic Functions .. DBSPVN, DBSQAD, DFB, DINTRV, DPFQAD, DPPQAD, XGETF, XSETF !***FIRST EXECUTABLE STATEMENT DBSPCK INTRINSIC ABS, MAX, SIN ! if ( kprint >= 2) write (LUN, 9000) ipass = 1 PI = 3.14159265358979324D0 ! ! Generate data. ! TOL = 1000.0D0*MAX(d1mach(4),1.0D-18) 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.0D0/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.0D0 ! ! Error test on DBINT4. ! call DBINT4 (X,Y,NDATA,IBCL,IBCR,FBCL,FBCR,KNT,T,BC,N,K,W) INBV = 1 DO 30 I = 1,NDATA XX = X(I) BV = DBVALU(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 = DBVALU(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 = DBVALU(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 DBSQAD (T,BC,N,K,X1,X2,BQUAD,W) LDC = 4 call DBSPPP (T,BC,N,K,LDC,C,XI,LXI,W) call DPPQAD (LDC,C,XI,LXI,K,X1,X2,Q(1)) call DBFQAD (DFB,T,BC,N,K,0,X1,X2,TOL,Q(2),IERR,W) ! ! Error test for quadratures. ! call DPFQAD (DFB,LDC,C,XI,LXI,K,0,X1,X2,TOL,Q(3),IERR) DO 90 I = 1,3 ER = ABS(BQUAD-Q(I)) if ( ER > TOL ) then ipass = 0 if ( kprint >= 2) write (LUN, 9040) end if 90 continue QSAVE(KNT) = BQUAD 110 continue ER = ABS(QSAVE(1)-QSAVE(2)) if ( ER > TOL ) then ipass = 0 if ( kprint >= 2) write (LUN, 9060) ! ! Check DBSPDR and DBSPEV against DBVALU, DPPVAL and DBSPVD. ! end if call DBSPDR (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 DBSPEV (T,ADIF,N,K,K,XX,INEV,SV,W) ATOL = TOL DO 130 J = 1,K SPV = DBVALU (T,BC,N,K,J-1,XX,INBV,W) ER = ABS(SPV-SV(J)) X2 = ABS(SV(J)) if ( X2 > 1.0D0) ER = ER/X2 if ( ER > ATOL ) then ipass = 0 if ( kprint >= 2) write (LUN, 9070) end if ATOL = 10.0D0*ATOL 130 continue ATOL = TOL DO 140 J = 1,K SPV = DPPVAL (LDC,C,XI,LXI,K,J-1,XX,INPPV) ER = ABS(SPV-SV(J)) X2 = ABS(SV(J)) if ( X2 > 1.0D0) ER = ER/X2 if ( ER > ATOL ) then ipass = 0 if ( kprint >= 2) write (LUN, 9080) end if ATOL = 10.0D0*ATOL 140 continue ATOL = TOL LDCC = 4 X1 = XX if ( I+I-1 == NDATA) X1 = T(N) NN = N + K call DINTRV (T,NN,X1,ILO,ILEFT,MFLAG) DO 160 J = 1,K call DBSPVD (T,K,J,XX,ILEFT,LDCC,CC,W) ER = 0.0D0 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.0D0) ER = ER/X2 if ( ER > ATOL ) then ipass = 0 if ( kprint >= 2) write (LUN, 9090) end if ATOL = 10.0D0*ATOL 160 continue 170 continue DO 220 K = 2,4 N = NDATA NMK = N - K DO 190 I = 1,K T(I) = X(1) T(N+I) = X(N) 190 continue XL = X(N) - X(1) DN = N - K + 1 DO 200 I = 1,NMK T(K+I) = X(1) + I*XL/DN 200 continue ! ! Error test on DBINTK. ! call DBINTK (X,Y,T,N,K,BC,QQ,W) INBV = 1 DO 210 I = 1,N XX = X(I) BV = DBVALU(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.0D0 W(2) = 4.0D0 W(3) = 2.0D0 W(4) = 0.5D0 W(5) = 4.0D0 ILO = 1 INEV = 1 INBV = 1 call DINTRV (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 = DBVALU (T,BC,N,K,ID,XX,INBV,QQ) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if ! call xerclr call DBSPEV (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 DBSPVN (T,JHIGH,K,ID,XX,ILEFT,SV,QQ,IWORK) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if ! call xerclr call DBFQAD (DFB,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 DBSPPP (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 DBSPDR (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 DBSQAD (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 DBSPVD (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 DBINTK (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 DBINT4 (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.0D0 call DBINT4 (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 DBINTK (X,Y,T,N,K,BC,QQ,ADIF) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if ! call xerclr X(1) = 0.0D0 ATOL = 1.0D0 KNTOPT = 3 DO 330 I = 1,3 QQ(I) = -0.30D0 + 0.10D0*(I-1) QQ(I+3) = 1.1D0 + 0.10D0*(I-1) 330 continue QQ(1) = 1.0D0 call DBINT4 (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 DBFQAD (DFB,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 = DPPVAL (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 DPFQAD (DFB,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 DPPQAD (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 DPFQAD (DFB,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 DBINT4 NOT SATISFIED') 9020 FORMAT (' ERROR TEST FOR INTERPOLATION BY DBINT4 NOT SATISFIED ', & 'BY FIRST DERIVATIVE') 9030 FORMAT (' ERROR TEST FOR INTERPOLATION BY DBINT4 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 DBSPEV AND DBVALU DO NOT AGREE') 9080 FORMAT (' COMPARISONS FROM DBSPEV AND DPPVAL DO NOT AGREE') 9090 FORMAT (' COMPARISONS FROM DBSPEV AND DBSPVD DO NOT AGREE') 9100 FORMAT (' ERROR TEST FOR INTERPOLATION BY DBINTK 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 subroutine DCHK12 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NKB, KB, NALF, ALF, NBET, BET, NINC, INC, NMAX, INCMAX, & !! DCHK12 !***SUBSIDIARY !***PURPOSE Test DGEMV and DGBMV. !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for DGEMV and DGBMV. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED DGBMV, DGEMV, DMAKE2, DMVCH, LDE, LDERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DCHK12 ! .. Parameters .. A, AA, AS, X, XX, XS, Y, YY, YS, YT, G) double precision ZERO, HALF ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 ) LOGICAL FATAL double precision EPS, THRESH integer INCMAX, KPRINT, NALF, NBET, NIDIM, NINC, NKB, & NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME double precision A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), & X( NMAX ), XS( NMAX*INCMAX ), & XX( NMAX*INCMAX ), Y( NMAX ), & YS( NMAX*INCMAX ), YT( NMAX ), & YY( NMAX*INCMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ), INC( NINC ), KB( NKB ) double precision ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL 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, & NL, NS, NERR LOGICAL BANDED, FTL, FULL, NULL, RESET, TRAN CHARACTER*1 TRANS, TRANSS ! .. Local Arrays .. CHARACTER*3 ICH ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LDE, LDERES ! .. External Subroutines .. EXTERNAL LDE, LDERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL DGBMV, DGEMV, DMAKE2, DMVCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN !***FIRST EXECUTABLE STATEMENT DCHK12 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 = ZERO 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 DMAKE2( 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 DMAKE2( '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 DMAKE2( '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 10 I = 1, LAA AS( I ) = AA( I ) 10 continue LDAS = LDA DO 20 I = 1, LX XS( I ) = XX( I ) 20 continue INCXS = INCX BLS = BETA DO 30 I = 1, LY YS( I ) = YY( I ) 30 continue ! ! Call the subroutine. ! INCYS = INCY if ( FULL ) then call DGEMV( TRANS, M, N, ALPHA, AA, & LDA, XX, INCX, BETA, YY, & INCY ) else if ( BANDED ) then call DGBMV( 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 ) = LDE( AS, AA, LAA ) ISAME( 6 ) = LDAS == LDA ISAME( 7 ) = LDE( XS, XX, LX ) ISAME( 8 ) = INCXS == INCX ISAME( 9 ) = BLS == BETA if ( NULL ) then ISAME( 10 ) = LDE( YS, YY, LY ) else ISAME( 10 ) = LDERES( '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 ) = LDE( AS, AA, LAA ) ISAME( 8 ) = LDAS == LDA ISAME( 9 ) = LDE( XS, XX, LX ) ISAME( 10 ) = INCXS == INCX ISAME( 11 ) = BLS == BETA if ( NULL ) then ISAME( 12 ) = LDE( YS, YY, LY ) else ISAME( 12 ) = LDERES( '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 DMVCH( 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, & ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, & ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, & ') .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of DCHK12. ! '******' ) end subroutine DCHK13 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NBET, BET, NMAX, A, AA, AS, B, BB, BS, C, CC, & !! DCHK13 !***SUBSIDIARY !***PURPOSE Test DGEMM. !***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 DGEMM. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED DGEMM, DMAKE3, DMMCH, LDE, LDERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DCHK13 ! .. Parameters .. CS, CT, G) double precision ZERO ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0D0) LOGICAL FATAL double precision EPS, THRESH integer KPRINT, NALF, NBET, NIDIM, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME double precision A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), G( NMAX ), & BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), & C( NMAX, NMAX ), CC( NMAX*NMAX ), & CS( NMAX*NMAX ), CT( NMAX ), B( NMAX, NMAX) ! .. Local Scalars .. integer IDIM( NIDIM ) double precision ALPHA, ALS, BETA, BLS, 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 LDE, LDERES ! .. External Subroutines .. EXTERNAL LDE, LDERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL DGEMM, DMAKE3, DMMCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN !***FIRST EXECUTABLE STATEMENT DCHK13 DATA ICH/'NTC'/ NARGS = 13 NC = 0 RESET = .TRUE. ! ERRMAX = ZERO 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 DMAKE3( '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 DMAKE3( '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 DMAKE3( '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 DO 10 I = 1, LAA AS( I ) = AA( I ) 10 continue 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 DGEMM( 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 ) = LDE( AS, AA, LAA ) ISAME( 8 ) = LDAS == LDA ISAME( 9 ) = LDE( BS, BB, LBB ) ISAME( 10 ) = LDBS == LDB ISAME( 11 ) = BLS == BETA if ( NULL ) then ISAME( 12 ) = LDE( CS, CC, LCC ) else ISAME( 12 ) = LDERES( 'GE', ' ', M, N, CS, & CC, LDC ) end if ! ! If data was incorrectly changed, report ! and return. ! 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 DMMCH( 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 continue ! 60 continue ! 70 continue ! 80 continue ! 90 continue ! 100 continue ! ! Report result. ! 110 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, ''',''', A1, ''',', & 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', & 'C,', I3, ').' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of DCHK13. ! '******' ) end subroutine DCHK22 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NKB, KB, NALF, ALF, NBET, BET, NINC, INC, NMAX, INCMAX, & !! DCHK22 !***SUBSIDIARY !***PURPOSE Test DSYMV, DSBMV and DSPMV. !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for DSYMV, DSBMV and DSPMV. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED DMAKE2, DMVCH, DSBMV, DSPMV, DSYMV, LDE, LDERES, ! NUMXER !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DCHK22 ! .. Parameters .. A, AA, AS, X, XX, XS, Y, YY, YS, YT, G) double precision ZERO, HALF ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 ) LOGICAL FATAL double precision EPS, THRESH integer INCMAX, KPRINT, NALF, NBET, NIDIM, NINC, NKB, & NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME double precision A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), & X( NMAX ), XS( NMAX*INCMAX ), & XX( NMAX*INCMAX ), Y( NMAX ), & YS( NMAX*INCMAX ), YT( NMAX ), & YY( NMAX*INCMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ), INC( NINC ), KB( NKB ) double precision ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL integer I, IA, IB, IC, IK, IN, INCX, INCXS, INCY, & INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY, & N, NARGS, NC, NK, NS, NERR LOGICAL BANDED, FTL, FULL, NULL, PACKED, RESET CHARACTER*1 UPLO, UPLOS ! .. Local Arrays .. CHARACTER*2 ICH ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LDE, LDERES ! .. External Subroutines .. EXTERNAL LDE, LDERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL DMAKE2, DMVCH, DSBMV, DSPMV, DSYMV ! .. Data statements .. INTRINSIC ABS, MAX !***FIRST EXECUTABLE STATEMENT DCHK22 DATA ICH/'UL'/ FULL = SNAME( 3: 3 ) == 'Y' BANDED = SNAME( 3: 3 ) == 'B' ! Define the number of arguments. PACKED = SNAME( 3: 3 ) == 'P' if ( FULL ) then NARGS = 10 else if ( BANDED ) then NARGS = 11 else if ( PACKED ) then NARGS = 9 ! end if NC = 0 RESET = .TRUE. ! ERRMAX = ZERO DO 110 IN = 1, NIDIM ! N = IDIM( IN ) if ( BANDED ) then NK = NKB else NK = 1 end if DO 100 IK = 1, NK if ( BANDED ) then K = KB( IK ) else K = N - 1 ! Set LDA to 1 more than minimum value if room. end if if ( BANDED ) then LDA = K + 1 else LDA = N end if if ( LDA < NMAX ) & ! Skip tests if not enough room. LDA = LDA + 1 if ( LDA > NMAX ) & GO TO 100 if ( PACKED ) then LAA = ( N*( N + 1 ) )/2 else LAA = LDA*N end if ! NULL = N <= 0 DO 90 IC = 1, 2 ! ! Generate the matrix A. ! UPLO = ICH( IC: IC ) TRANSL = ZERO call DMAKE2( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA, & ! LDA, K, K, RESET, TRANSL ) DO 80 IX = 1, NINC INCX = INC( IX ) ! ! Generate the vector X. ! LX = ABS( INCX )*N TRANSL = HALF call DMAKE2( 'GE', ' ', ' ', 1, N, X, 1, XX, & ABS( INCX ), 0, N - 1, RESET, TRANSL ) if ( N > 1 ) then X( N/2 ) = ZERO XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO ! end if DO 70 IY = 1, NINC INCY = INC( IY ) ! LY = ABS( INCY )*N DO 60 IA = 1, NALF ! ALPHA = ALF( IA ) DO 50 IB = 1, NBET ! ! Generate the vector Y. ! BETA = BET( IB ) TRANSL = ZERO call DMAKE2( 'GE', ' ', ' ', 1, N, Y, 1, YY, & ABS( INCY ), 0, N - 1, RESET, & ! TRANSL ) ! ! Save every datum before calling the ! subroutine. ! NC = NC + 1 UPLOS = UPLO NS = N KS = K ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 continue LDAS = LDA DO 20 I = 1, LX XS( I ) = XX( I ) 20 continue INCXS = INCX BLS = BETA DO 30 I = 1, LY YS( I ) = YY( I ) 30 continue ! ! Call the subroutine. ! INCYS = INCY if ( FULL ) then call DSYMV( UPLO, N, ALPHA, AA, LDA, XX, & INCX, BETA, YY, INCY ) else if ( BANDED ) then call DSBMV( UPLO, N, K, ALPHA, AA, LDA, & XX, INCX, BETA, YY, INCY ) else if ( PACKED ) then call DSPMV( UPLO, N, ALPHA, AA, 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 = 9992 ) end if FATAL = .TRUE. ! ! See what data changed inside subroutines. ! end if ISAME( 1 ) = UPLO == UPLOS ISAME( 2 ) = NS == N if ( FULL ) then ISAME( 3 ) = ALS == ALPHA ISAME( 4 ) = LDE( AS, AA, LAA ) ISAME( 5 ) = LDAS == LDA ISAME( 6 ) = LDE( XS, XX, LX ) ISAME( 7 ) = INCXS == INCX ISAME( 8 ) = BLS == BETA if ( NULL ) then ISAME( 9 ) = LDE( YS, YY, LY ) else ISAME( 9 ) = LDERES( 'GE', ' ', 1, N, & YS, YY, ABS( INCY ) ) end if ISAME( 10 ) = INCYS == INCY else if ( BANDED ) then ISAME( 3 ) = KS == K ISAME( 4 ) = ALS == ALPHA ISAME( 5 ) = LDE( AS, AA, LAA ) ISAME( 6 ) = LDAS == LDA ISAME( 7 ) = LDE( XS, XX, LX ) ISAME( 8 ) = INCXS == INCX ISAME( 9 ) = BLS == BETA if ( NULL ) then ISAME( 10 ) = LDE( YS, YY, LY ) else ISAME( 10 ) = LDERES( 'GE', ' ', 1, N, & YS, YY, ABS( INCY ) ) end if ISAME( 11 ) = INCYS == INCY else if ( PACKED ) then ISAME( 3 ) = ALS == ALPHA ISAME( 4 ) = LDE( AS, AA, LAA ) ISAME( 5 ) = LDE( XS, XX, LX ) ISAME( 6 ) = INCXS == INCX ISAME( 7 ) = BLS == BETA if ( NULL ) then ISAME( 8 ) = LDE( YS, YY, LY ) else ISAME( 8 ) = LDERES( 'GE', ' ', 1, N, & YS, YY, ABS( INCY ) ) end if ISAME( 9 ) = 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 DMVCH( 'N', N, 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 = 9993 )NC, & SNAME, UPLO, N, ALPHA, & LDA, INCX, BETA, INCY else if ( BANDED ) then write ( NOUT, FMT = 9994 )NC, & SNAME, UPLO, N, ALPHA, & INCX, BETA, INCY else if ( PACKED ) then write ( NOUT, FMT = 9995 )NC, & SNAME, UPLO, N, ALPHA, INCX, & BETA, INCY end if end if ! end if ! 50 continue ! 60 continue ! 70 continue ! 80 continue ! 90 continue ! 100 continue ! ! Report result. ! 110 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, ''',', I3, ',', F4.1, ', AP', & ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1, & ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, & ') .' ) 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', A,', & I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of DCHK22. ! '******' ) end subroutine DCHK23 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NBET, BET, NMAX, A, AA, AS, B, BB, BS, C, CC, & !! DCHK23 !***SUBSIDIARY !***PURPOSE Test DSYMM. !***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 DSYMM. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED DMAKE3, DMMCH, DSYMM, LDE, LDERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DCHK23 ! .. Parameters .. CS, CT, G) double precision ZERO ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0D0) LOGICAL FATAL double precision EPS, THRESH integer KPRINT, NALF, NBET, NIDIM, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME double precision A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), G( NMAX ), & BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), & C( NMAX, NMAX ), CC( NMAX*NMAX ), & CS( NMAX*NMAX ), CT( NMAX ), B( NMAX, NMAX) ! .. Local Scalars .. integer IDIM( NIDIM ) double precision ALPHA, ALS, BETA, BLS, ERR, ERRMAX integer I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, & LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, & NARGS, NC, NERR, NS LOGICAL FTL, LEFT, NULL, RESET CHARACTER*1 SIDE, SIDES, UPLO, UPLOS ! .. Local Arrays .. CHARACTER*2 ICHS, ICHU ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LDE, LDERES ! .. External Subroutines .. EXTERNAL LDE, LDERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL DSYMM, DMAKE3, DMMCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN !***FIRST EXECUTABLE STATEMENT DCHK23 DATA ICHS/'LR'/, ICHU/'UL'/ NARGS = 12 NC = 0 RESET = .TRUE. ! ERRMAX = ZERO DO 100 IM = 1, NIDIM ! M = IDIM( IM ) DO 90 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 90 LCC = LDC*N ! ! Set LDB to 1 more than minimum value if room. NULL = N <= 0.OR.M <= 0 LDB = M if ( LDB < NMAX ) & ! Skip tests if not enough room. LDB = LDB + 1 if ( LDB > NMAX ) & GO TO 90 ! ! Generate the matrix B. ! LBB = LDB*N call DMAKE3( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, & ! ZERO ) DO 80 ICS = 1, 2 SIDE = ICHS( ICS: ICS ) ! LEFT = SIDE == 'L' if ( LEFT ) then NA = M else NA = N ! Set LDA to 1 more than minimum value if room. end if LDA = NA if ( LDA < NMAX ) & ! Skip tests if not enough room. LDA = LDA + 1 if ( LDA > NMAX ) & GO TO 80 ! LAA = LDA*NA DO 70 ICU = 1, 2 ! ! Generate the symmetric matrix A. ! UPLO = ICHU( ICU: ICU ) call DMAKE3('SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA, & ! RESET, ZERO ) DO 60 IA = 1, NALF ! ALPHA = ALF( IA ) DO 50 IB = 1, NBET ! ! Generate the matrix C. ! BETA = BET( IB ) call DMAKE3( 'GE', ' ', ' ', M, N, C, NMAX, CC, & ! LDC, RESET, ZERO ) ! ! Save every datum before calling the ! subroutine. ! NC = NC + 1 SIDES = SIDE UPLOS = UPLO MS = M NS = N ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 continue 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 DSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, & ! ! Check if error-exit was taken incorrectly. ! 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 ) = SIDES == SIDE ISAME( 2 ) = UPLOS == UPLO ISAME( 3 ) = MS == M ISAME( 4 ) = NS == N ISAME( 5 ) = ALS == ALPHA ISAME( 6 ) = LDE( AS, AA, LAA ) ISAME( 7 ) = LDAS == LDA ISAME( 8 ) = LDE( BS, BB, LBB ) ISAME( 9 ) = LDBS == LDB ISAME( 10 ) = BLS == BETA if ( NULL ) then ISAME( 11 ) = LDE( CS, CC, LCC ) else ISAME( 11 ) = LDERES( 'GE', ' ', M, N, CS, & CC, LDC ) end if ! ! If data was incorrectly changed, report and ! return. ! ISAME( 12 ) = 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 if ( LEFT ) then call DMMCH( 'N', 'N', M, N, M, ALPHA, A, & NMAX, B, NMAX, BETA, C, NMAX, & CT, G, CC, LDC, EPS, ERR, & FTL, NOUT, .TRUE., kprint ) else call DMMCH( 'N', 'N', M, N, N, ALPHA, B, & NMAX, A, NMAX, BETA, C, NMAX, & CT, G, CC, LDC, EPS, ERR, & FTL, NOUT, .TRUE., kprint ) end if 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, SIDE, & UPLO, M, N, ALPHA, LDA, LDB, BETA, & LDC end if ! end if ! 50 continue ! 60 continue ! 70 continue ! 80 continue ! 90 continue ! ! Report result. ! 100 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, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), & F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', & ' .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of DCHK23. ! '******' ) end subroutine DCHK32 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NKB, KB, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, & !! DCHK32 !***SUBSIDIARY !***PURPOSE Test DTRMV, DTBMV, DTPMV, DTRSV, DTBSV and DTPSV. !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for DTRMV, DTBMV, DTPMV, DTRSV, DTBSV and DTPSV. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED DMAKE2, DMVCH, DTBMV, DTBSV, DTPMV, DTPSV, DTRMV, ! DTRSV, LDE, LDERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DCHK32 ! .. Parameters .. XT, G, Z) double precision ZERO, HALF, ONE ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) LOGICAL FATAL double precision EPS, THRESH integer INCMAX, KPRINT, NIDIM, NINC, NKB, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME double precision A( NMAX, NMAX ), AA( NMAX*NMAX ), & AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), & XS( NMAX*INCMAX ), XT( NMAX ), & XX( NMAX*INCMAX ), Z( NMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ), INC( NINC ), KB( NKB ) double precision ERR, ERRMAX, TRANSL integer I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K, & KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS, & NERR LOGICAL BANDED, FTL, FULL, NULL, PACKED, RESET CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS CHARACTER*2 ICHD, ICHU ! .. Local Arrays .. CHARACTER*3 ICHT ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LDE, LDERES ! .. External Subroutines .. EXTERNAL LDE, LDERES, NUMXER EXTERNAL DMAKE2, DMVCH, DTBMV, DTBSV, DTPMV, DTPSV, & ! .. Intrinsic Functions .. DTRMV, DTRSV ! .. Data statements .. INTRINSIC ABS, MAX !***FIRST EXECUTABLE STATEMENT DCHK32 DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/ FULL = SNAME( 3: 3 ) == 'R' BANDED = SNAME( 3: 3 ) == 'B' ! Define the number of arguments. PACKED = SNAME( 3: 3 ) == 'P' if ( FULL ) then NARGS = 8 else if ( BANDED ) then NARGS = 9 else if ( PACKED ) then NARGS = 7 ! end if NC = 0 RESET = .TRUE. ! Set up zero vector for DMVCH. ERRMAX = ZERO DO 10 I = 1, NMAX Z( I ) = ZERO ! 10 continue DO 110 IN = 1, NIDIM ! N = IDIM( IN ) if ( BANDED ) then NK = NKB else NK = 1 end if DO 100 IK = 1, NK if ( BANDED ) then K = KB( IK ) else K = N - 1 ! Set LDA to 1 more than minimum value if room. end if if ( BANDED ) then LDA = K + 1 else LDA = N end if if ( LDA < NMAX ) & ! Skip tests if not enough room. LDA = LDA + 1 if ( LDA > NMAX ) & GO TO 100 if ( PACKED ) then LAA = ( N*( N + 1 ) )/2 else LAA = LDA*N end if ! NULL = N <= 0 DO 90 ICU = 1, 2 ! UPLO = ICHU( ICU: ICU ) DO 80 ICT = 1, 3 ! TRANS = ICHT( ICT: ICT ) DO 70 ICD = 1, 2 ! ! Generate the matrix A. ! DIAG = ICHD( ICD: ICD ) TRANSL = ZERO call DMAKE2( SNAME( 2: 3 ), UPLO, DIAG, N, N, A, & ! NMAX, AA, LDA, K, K, RESET, TRANSL ) DO 60 IX = 1, NINC INCX = INC( IX ) ! ! Generate the vector X. ! LX = ABS( INCX )*N TRANSL = HALF call DMAKE2( 'GE', ' ', ' ', 1, N, X, 1, XX, & ABS( INCX ), 0, N - 1, RESET, & TRANSL ) if ( N > 1 ) then X( N/2 ) = ZERO XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO ! end if ! ! Save every datum before calling the subroutine. ! NC = NC + 1 UPLOS = UPLO TRANSS = TRANS DIAGS = DIAG NS = N KS = K DO 20 I = 1, LAA AS( I ) = AA( I ) 20 continue LDAS = LDA DO 30 I = 1, LX XS( I ) = XX( I ) 30 continue ! ! Call the subroutine. ! INCXS = INCX if ( SNAME( 4: 5 ) == 'MV' ) then if ( FULL ) then call DTRMV( UPLO, TRANS, DIAG, N, AA, LDA, & XX, INCX ) else if ( BANDED ) then call DTBMV( UPLO, TRANS, DIAG, N, K, AA, & LDA, XX, INCX ) else if ( PACKED ) then call DTPMV( UPLO, TRANS, DIAG, N, AA, XX, & INCX ) end if else if ( SNAME( 4: 5 ) == 'SV' ) then if ( FULL ) then call DTRSV( UPLO, TRANS, DIAG, N, AA, LDA, & XX, INCX ) else if ( BANDED ) then call DTBSV( UPLO, TRANS, DIAG, N, K, AA, & LDA, XX, INCX ) else if ( PACKED ) then call DTPSV( UPLO, TRANS, DIAG, N, AA, XX, & INCX ) end if ! ! Check if error-exit was taken incorrectly. ! end if if ( NUMXER(NERR) /= 0 ) then if ( kprint >= 2 ) then write ( NOUT, FMT = 9992 ) end if FATAL = .TRUE. ! ! See what data changed inside subroutines. ! end if ISAME( 1 ) = UPLO == UPLOS ISAME( 2 ) = TRANS == TRANSS ISAME( 3 ) = DIAG == DIAGS ISAME( 4 ) = NS == N if ( FULL ) then ISAME( 5 ) = LDE( AS, AA, LAA ) ISAME( 6 ) = LDAS == LDA if ( NULL ) then ISAME( 7 ) = LDE( XS, XX, LX ) else ISAME( 7 ) = LDERES( 'GE', ' ', 1, N, XS, & XX, ABS( INCX ) ) end if ISAME( 8 ) = INCXS == INCX else if ( BANDED ) then ISAME( 5 ) = KS == K ISAME( 6 ) = LDE( AS, AA, LAA ) ISAME( 7 ) = LDAS == LDA if ( NULL ) then ISAME( 8 ) = LDE( XS, XX, LX ) else ISAME( 8 ) = LDERES( 'GE', ' ', 1, N, XS, & XX, ABS( INCX ) ) end if ISAME( 9 ) = INCXS == INCX else if ( PACKED ) then ISAME( 5 ) = LDE( AS, AA, LAA ) if ( NULL ) then ISAME( 6 ) = LDE( XS, XX, LX ) else ISAME( 6 ) = LDERES( 'GE', ' ', 1, N, XS, & XX, ABS( INCX ) ) end if ISAME( 7 ) = INCXS == INCX ! ! 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. if ( .NOT.NULL ) then ! ! Check the result. ! if ( SNAME( 4: 5 ) == 'MV' ) then call DMVCH( TRANS, N, N, ONE, A, NMAX, X, & INCX, ZERO, Z, INCX, XT, G, & XX, EPS, ERR, FTL, NOUT, & .TRUE., kprint ) ! ! Compute approximation to original vector. ! else if ( SNAME( 4: 5 ) == 'SV' ) then DO 50 I = 1, N Z( I ) = XX( 1 + ( I - 1 )* & ABS( INCX ) ) XX( 1 + ( I - 1 )*ABS( INCX ) ) & = X( I ) 50 continue call DMVCH( TRANS, N, N, ONE, A, NMAX, Z, & INCX, ZERO, X, INCX, XT, G, & XX, EPS, ERR, FTL, NOUT, & .FALSE., kprint ) end if 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 = 9993 )NC, & SNAME, UPLO, TRANS, DIAG, N, & LDA, INCX else if ( BANDED ) then write ( NOUT, FMT = 9994 )NC, & SNAME, UPLO, TRANS, DIAG, N, & K, LDA, INCX else if ( PACKED ) then write ( NOUT, FMT = 9995 )NC, & SNAME, UPLO, TRANS, DIAG, & N, INCX end if end if ! end if ! 60 continue ! 70 continue ! 80 continue ! 90 continue ! 100 continue ! ! Report result. ! 110 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, '(', 3( '''', A1, ''',' ), I3, ', AP, ', & 'X,', I2, ') .' ) 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ), & ' A,', I3, ', X,', I2, ') .' ) 9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,', & I3, ', X,', I2, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of DCHK32. ! '******' ) end subroutine DCHK33 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & !! DCHK33 !***SUBSIDIARY !***PURPOSE Test DTRMM and DTRSM. !***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 DTRMM and DTRSM. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED DMAKE3, DMMCH, DTRMM, DTRSM, LDE, LDERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DCHK33 ! .. Parameters .. IDIM, NALF, ALF, NMAX, A, AA, AS, B, BB, BS, CT, G, C) double precision ZERO, ONE ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) LOGICAL FATAL double precision EPS, THRESH integer KPRINT, NALF, NIDIM, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME double precision A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), G( NMAX ), & BB( NMAX*NMAX ), BS( NMAX*NMAX ), & C( NMAX, NMAX ), & CT( NMAX ), B( NMAX, NMAX) ! .. Local Scalars .. integer IDIM( NIDIM ) double precision ALPHA, ALS, ERR, ERRMAX integer I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, & LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, & NERR, NS LOGICAL FTL, LEFT, NULL, RESET CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, & UPLOS CHARACTER*2 ICHS, ICHU, ICHD ! .. Local Arrays .. CHARACTER*3 ICHT ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LDE, LDERES ! .. External Subroutines .. EXTERNAL LDE, LDERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL DTRMM, DTRSM, DMAKE3, DMMCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN !***FIRST EXECUTABLE STATEMENT DCHK33 DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ NARGS = 11 NC = 0 RESET = .TRUE. ! Set up zero matrix for DMMCH. ERRMAX = ZERO DO 20 J = 1, NMAX DO 10 I = 1, NMAX C( I, J ) = ZERO 10 continue ! 20 continue DO 140 IM = 1, NIDIM ! M = IDIM( IM ) DO 130 IN = 1, NIDIM ! Set LDB to 1 more than minimum value if room. N = IDIM( IN ) LDB = M if ( LDB < NMAX ) & ! Skip tests if not enough room. LDB = LDB + 1 if ( LDB > NMAX ) & GO TO 130 LBB = LDB*N ! NULL = M <= 0.OR.N <= 0 DO 120 ICS = 1, 2 SIDE = ICHS( ICS: ICS ) LEFT = SIDE == 'L' if ( LEFT ) then NA = M else NA = N ! Set LDA to 1 more than minimum value if room. end if LDA = NA if ( LDA < NMAX ) & ! Skip tests if not enough room. LDA = LDA + 1 if ( LDA > NMAX ) & GO TO 130 ! LAA = LDA*NA DO 110 ICU = 1, 2 ! UPLO = ICHU( ICU: ICU ) DO 100 ICT = 1, 3 ! TRANSA = ICHT( ICT: ICT ) DO 90 ICD = 1, 2 ! DIAG = ICHD( ICD: ICD ) DO 80 IA = 1, NALF ! ! Generate the matrix A. ! ALPHA = ALF( IA ) call DMAKE3( 'TR', UPLO, DIAG, NA, NA, A, & ! ! Generate the matrix B. ! NMAX, AA, LDA, RESET, ZERO ) call DMAKE3( 'GE', ' ', ' ', M, N, B, NMAX, & ! BB, LDB, RESET, ZERO ) ! ! Save every datum before calling the ! subroutine. ! NC = NC + 1 SIDES = SIDE UPLOS = UPLO TRANAS = TRANSA DIAGS = DIAG MS = M NS = N ALS = ALPHA DO 30 I = 1, LAA AS( I ) = AA( I ) 30 continue LDAS = LDA DO 40 I = 1, LBB BS( I ) = BB( I ) 40 continue ! ! Call the subroutine. ! LDBS = LDB if ( SNAME( 4: 5 ) == 'MM' ) then call DTRMM( SIDE, UPLO, TRANSA, DIAG, M, & N, ALPHA, AA, LDA, BB, LDB ) else if ( SNAME( 4: 5 ) == 'SM' ) then call DTRSM( SIDE, UPLO, TRANSA, DIAG, M, & N, ALPHA, AA, LDA, BB, LDB ) ! ! Check if error-exit was taken incorrectly. ! end if 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 ) = SIDES == SIDE ISAME( 2 ) = UPLOS == UPLO ISAME( 3 ) = TRANAS == TRANSA ISAME( 4 ) = DIAGS == DIAG ISAME( 5 ) = MS == M ISAME( 6 ) = NS == N ISAME( 7 ) = ALS == ALPHA ISAME( 8 ) = LDE( AS, AA, LAA ) ISAME( 9 ) = LDAS == LDA if ( NULL ) then ISAME( 10 ) = LDE( BS, BB, LBB ) else ISAME( 10 ) = LDERES( 'GE', ' ', M, N, BS, & BB, LDB ) end if ! ! If data was incorrectly changed, report and ! return. ! ISAME( 11 ) = LDBS == LDB DO 50 I = 1, NARGS if ( .NOT. ISAME( I ) ) then FATAL = .TRUE. if ( kprint >= 2 ) then write ( NOUT, FMT = 9998 )I end if end if ! 50 continue FTL = .FALSE. if ( .NOT.NULL ) then ! ! Check the result. ! if ( SNAME( 4: 5 ) == 'MM' ) then if ( LEFT ) then call DMMCH( TRANSA, 'N', M, N, M, & ALPHA, A, NMAX, B, NMAX, & ZERO, C, NMAX, CT, G, & BB, LDB, EPS, ERR, & FTL, NOUT, .TRUE., & kprint ) else call DMMCH( 'N', TRANSA, M, N, N, & ALPHA, B, NMAX, A, NMAX, & ZERO, C, NMAX, CT, G, & BB, LDB, EPS, ERR, & FTL, NOUT, .TRUE., & kprint ) end if ! ! Compute approximation to original ! matrix. ! else if ( SNAME( 4: 5 ) == 'SM' ) then DO 70 J = 1, N DO 60 I = 1, M C( I, J ) = BB( I + ( J - 1 )* & LDB ) BB( I + ( J - 1 )*LDB ) = ALPHA* & B( I, J ) 60 continue ! 70 continue if ( LEFT ) then call DMMCH( TRANSA, 'N', M, N, M, & ONE, A, NMAX, C, NMAX, & ZERO, B, NMAX, CT, G, & BB, LDB, EPS, ERR, & FTL, NOUT, .FALSE., & kprint ) else call DMMCH( 'N', TRANSA, M, N, N, & ONE, C, NMAX, A, NMAX, & ZERO, B, NMAX, CT, G, & BB, LDB, EPS, ERR, & FTL, NOUT, .FALSE., & kprint ) end if end if 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, SIDE, UPLO, TRANSA, & DIAG, M, N, ALPHA, LDA, LDB end if ! end if ! 80 continue ! 90 continue ! 100 continue ! 110 continue ! 120 continue ! 130 continue ! ! Report result. ! 140 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, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), & F4.1, ', A,', I3, ', B,', I3, ') .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of DCHK33. ! '******' ) end subroutine DCHK42 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, & !! DCHK42 !***SUBSIDIARY !***PURPOSE Test DGER. !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for DGER. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED DGER, DMAKE2, DMVCH, LDE, LDERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DCHK42 ! .. Parameters .. Y, YY, YS, YT, G, Z) double precision ZERO, HALF, ONE ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) LOGICAL FATAL double precision EPS, THRESH integer INCMAX, KPRINT, NALF, NIDIM, NINC, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME double precision A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), & XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), & Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), & YY( NMAX*INCMAX ), Z( NMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ), INC( NINC ) double precision ALPHA, ALS, ERR, ERRMAX, TRANSL integer I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, & IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, & NC, ND, NS, NERR ! .. Local Arrays .. LOGICAL FTL, NULL, RESET double precision W( 1 ) ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LDE, LDERES ! .. External Subroutines .. EXTERNAL LDE, LDERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL DGER, DMAKE2, DMVCH !***FIRST EXECUTABLE STATEMENT DCHK42 ! Define the number of arguments. INTRINSIC ABS, MAX, MIN ! NARGS = 9 NC = 0 RESET = .TRUE. ! ERRMAX = ZERO 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 ) & ! ! Set LDA to 1 more than minimum value if room. M = min ( N + ND, NMAX ) LDA = M if ( LDA < NMAX ) & ! Skip tests if not enough room. LDA = LDA + 1 if ( LDA > NMAX ) & GO TO 110 LAA = LDA*N ! NULL = N <= 0.OR.M <= 0 DO 100 IX = 1, NINC INCX = INC( IX ) ! ! Generate the vector X. ! LX = ABS( INCX )*M TRANSL = HALF call DMAKE2( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), & 0, M - 1, RESET, TRANSL ) if ( M > 1 ) then X( M/2 ) = ZERO XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO ! end if DO 90 IY = 1, NINC INCY = INC( IY ) ! ! Generate the vector Y. ! LY = ABS( INCY )*N TRANSL = ZERO call DMAKE2( 'GE', ' ', ' ', 1, N, Y, 1, YY, & ABS( INCY ), 0, N - 1, RESET, TRANSL ) if ( N > 1 ) then Y( N/2 ) = ZERO YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO ! end if DO 80 IA = 1, NALF ! ! Generate the matrix A. ! ALPHA = ALF( IA ) TRANSL = ZERO call DMAKE2(SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, & ! AA, LDA, M - 1, N - 1, RESET, TRANSL ) ! ! Save every datum before calling the subroutine. ! NC = NC + 1 MS = M NS = N ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 continue LDAS = LDA DO 20 I = 1, LX XS( I ) = XX( I ) 20 continue INCXS = INCX DO 30 I = 1, LY YS( I ) = YY( I ) 30 continue ! ! Call the subroutine. ! INCYS = INCY call DGER( M, N, ALPHA, XX, INCX, YY, INCY, AA, & ! ! Check if error-exit was taken incorrectly. ! LDA ) if ( NUMXER(NERR) /= 0 ) then if ( kprint >= 2 ) then write ( NOUT, FMT = 9993 ) end if FATAL = .TRUE. ! ! See what data changed inside subroutine. ! end if ISAME( 1 ) = MS == M ISAME( 2 ) = NS == N ISAME( 3 ) = ALS == ALPHA ISAME( 4 ) = LDE( XS, XX, LX ) ISAME( 5 ) = INCXS == INCX ISAME( 6 ) = LDE( YS, YY, LY ) ISAME( 7 ) = INCYS == INCY if ( NULL ) then ISAME( 8 ) = LDE( AS, AA, LAA ) else ISAME( 8 ) = LDERES( 'GE', ' ', M, N, AS, AA, & LDA ) end if ! ! If data was incorrectly changed, report and return. ! ISAME( 9 ) = LDAS == LDA 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 column by column. ! if ( .NOT.NULL ) then if ( INCX > 0 ) then DO 50 I = 1, M Z( I ) = X( I ) 50 continue else DO 60 I = 1, M Z( I ) = X( M - I + 1 ) 60 continue end if DO 70 J = 1, N if ( INCY > 0 ) then W( 1 ) = Y( J ) else W( 1 ) = Y( N - J + 1 ) end if call DMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1, & ONE, A( 1, J ), 1, YT, G, & AA( 1 + ( J - 1 )*LDA ), EPS, & ERR, FTL, NOUT, .TRUE., KPRINT) ERRMAX = max ( ERRMAX, ERR ) 70 continue end if if ( FTL ) then FATAL = .TRUE. if ( kprint >= 3 ) then write ( NOUT, FMT = 9995 )J write ( NOUT, FMT = 9996 )SNAME write ( NOUT, FMT = 9994 )NC, & SNAME, M, N, ALPHA, INCX, INCY, & LDA end if ! end if ! 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( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), F4.1, ', X,', I2, & ', Y,', I2, ', A,', I3, ') .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of DCHK42. ! '******' ) end subroutine DCHK43 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NBET, BET, NMAX, A, AA, AS, B, BB, BS, C, CC, & !! DCHK43 !***SUBSIDIARY !***PURPOSE Test DSYRK. !***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 DSYRK. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED DMAKE3, DMMCH, DSYRK, LDE, LDERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DCHK43 ! .. Parameters .. CS, CT, G) double precision ZERO ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0D0 ) LOGICAL FATAL double precision EPS, THRESH integer KPRINT, NALF, NBET, NIDIM, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME double precision A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), G( NMAX ), & BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), & C( NMAX, NMAX ), CC( NMAX*NMAX ), & CT( NMAX ), B( NMAX, NMAX), CS (NMAX*NMAX) ! .. Local Scalars .. integer IDIM( NIDIM ) double precision ALPHA, ALS, BETA, BETS, ERR, ERRMAX integer I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, & LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, & NERR, NS, NARGS, NC LOGICAL FTL, NULL, RESET, TRAN, UPPER CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS CHARACTER*2 ICHU ! .. Local Arrays .. CHARACTER*3 ICHT ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LDE, LDERES ! .. External Subroutines .. EXTERNAL LDE, LDERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL DSYRK, DMAKE3, DMMCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN !***FIRST EXECUTABLE STATEMENT DCHK43 DATA ICHU/'UL'/, ICHT/'NTC'/ NARGS = 10 NC = 0 RESET = .TRUE. ! ERRMAX = ZERO DO 100 IN = 1, NIDIM ! Set LDC to 1 more than minimum value if room. N = IDIM( IN ) LDC = N if ( LDC < NMAX ) & ! Skip tests if not enough room. LDC = LDC + 1 if ( LDC > NMAX ) & GO TO 100 LCC = LDC*N ! NULL = N <= 0 DO 90 IK = 1, NIDIM ! K = IDIM( IK ) DO 80 ICT = 1, 3 TRANS = ICHT( ICT: ICT ) TRAN = TRANS == 'T'.OR.TRANS == 'C' if ( TRAN ) then MA = K NA = N else MA = N 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 DMAKE3( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, & ! RESET, ZERO ) DO 70 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) ! UPPER = UPLO == 'U' DO 60 IA = 1, NALF ! ALPHA = ALF( IA ) DO 50 IB = 1, NBET ! ! Generate the matrix C. ! BETA = BET( IB ) call DMAKE3( 'SY', UPLO, ' ', N, N, C, NMAX, CC, & ! LDC, RESET, ZERO ) ! ! Save every datum before calling the subroutine. ! NC = NC + 1 UPLOS = UPLO TRANSS = TRANS NS = N KS = K ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 continue LDAS = LDA BETS = BETA DO 20 I = 1, LCC CS( I ) = CC( I ) 20 continue ! ! Call the subroutine. ! LDCS = LDC call DSYRK( UPLO, TRANS, N, K, ALPHA, AA, LDA, & ! ! Check if error-exit was taken incorrectly. ! BETA, CC, LDC ) 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 ) = UPLOS == UPLO ISAME( 2 ) = TRANSS == TRANS ISAME( 3 ) = NS == N ISAME( 4 ) = KS == K ISAME( 5 ) = ALS == ALPHA ISAME( 6 ) = LDE( AS, AA, LAA ) ISAME( 7 ) = LDAS == LDA ISAME( 8 ) = BETS == BETA if ( NULL ) then ISAME( 9 ) = LDE( CS, CC, LCC ) else ISAME( 9 ) = LDERES( 'SY', UPLO, N, N, CS, & CC, LDC ) end if ! ! If data was incorrectly changed, report and ! return. ! ISAME( 10 ) = LDCS == LDC DO 30 I = 1, NARGS if ( .NOT. ISAME( I ) ) then FATAL = .TRUE. if ( kprint >= 2 ) then write ( NOUT, FMT = 9998 )I end if end if ! 30 continue FTL = .FALSE. ! ! Check the result column by column. ! if ( .NOT.NULL ) then JC = 1 DO 40 J = 1, N if ( UPPER ) then JJ = 1 LJ = J else JJ = J LJ = N - J + 1 end if if ( TRAN ) then call DMMCH( 'T', 'N', LJ, 1, K, ALPHA, & A( 1, JJ ), NMAX, & A( 1, J ), NMAX, BETA, & C( JJ, J ), NMAX, CT, G, & CC( JC ), LDC, EPS, ERR, & FTL, NOUT, .TRUE., & kprint ) else call DMMCH( 'N', 'T', LJ, 1, K, ALPHA, & A( JJ, 1 ), NMAX, & A( J, 1 ), NMAX, BETA, & C( JJ, J ), NMAX, CT, G, & CC( JC ), LDC, EPS, ERR, & FTL, NOUT, .TRUE., & kprint ) end if if ( UPPER ) then JC = JC + LDC else JC = JC + LDC + 1 end if ERRMAX = max ( ERRMAX, ERR ) 40 continue end if if ( FTL ) then FATAL = .TRUE. if ( kprint >= 3 ) then write ( NOUT, FMT = 9996 )SNAME write ( NOUT, FMT = 9994 )NC, & SNAME, UPLO, TRANS, & N, K, ALPHA, LDA, BETA, LDC end if ! end if ! 50 continue ! 60 continue ! 70 continue ! 80 continue ! 90 continue ! ! Report result. ! 100 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:' ) 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), & F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of DCHK43. ! '******' ) end subroutine DCHK52 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, & !! DCHK52 !***SUBSIDIARY !***PURPOSE Quick check for DSYR and DSPR. !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for DSYR and DSPR. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED DMAKE2, DMVCH, DSPR, DSYR, LDE, LDERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DCHK52 ! .. Parameters .. Y, YY, YS, YT, G, Z) double precision ZERO, HALF, ONE ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) LOGICAL FATAL double precision EPS, THRESH integer INCMAX, KPRINT, NALF, NIDIM, NINC, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME double precision A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), & XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), & Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), & YY( NMAX*INCMAX ), Z( NMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ), INC( NINC ) double precision ALPHA, ALS, ERR, ERRMAX, TRANSL integer I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA, & LDA, LDAS, LJ, LX, N, NARGS, NC, NS, NERR LOGICAL FTL, FULL, NULL, PACKED, RESET, UPPER CHARACTER*1 UPLO, UPLOS ! .. Local Arrays .. CHARACTER*2 ICH double precision W( 1 ) ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LDE, LDERES ! .. External Subroutines .. EXTERNAL LDE, LDERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL DMAKE2, DMVCH, DSPR, DSYR ! .. Data statements .. INTRINSIC ABS, MAX !***FIRST EXECUTABLE STATEMENT DCHK52 DATA ICH/'UL'/ FULL = SNAME( 3: 3 ) == 'Y' ! Define the number of arguments. PACKED = SNAME( 3: 3 ) == 'P' if ( FULL ) then NARGS = 7 else if ( PACKED ) then NARGS = 6 ! end if NC = 0 RESET = .TRUE. ! ERRMAX = ZERO DO 100 IN = 1, NIDIM ! Set LDA to 1 more than minimum value if room. N = IDIM( IN ) LDA = N if ( LDA < NMAX ) & ! Skip tests if not enough room. LDA = LDA + 1 if ( LDA > NMAX ) & GO TO 100 if ( PACKED ) then LAA = ( N*( N + 1 ) )/2 else LAA = LDA*N ! end if DO 90 IC = 1, 2 UPLO = ICH( IC: IC ) ! UPPER = UPLO == 'U' DO 80 IX = 1, NINC INCX = INC( IX ) ! ! Generate the vector X. ! LX = ABS( INCX )*N TRANSL = HALF call DMAKE2( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), & 0, N - 1, RESET, TRANSL ) if ( N > 1 ) then X( N/2 ) = ZERO XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO ! end if DO 70 IA = 1, NALF ALPHA = ALF( IA ) ! ! Generate the matrix A. ! NULL = N <= 0.OR.ALPHA == ZERO TRANSL = ZERO call DMAKE2( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, & ! AA, LDA, N - 1, N - 1, RESET, TRANSL ) ! ! Save every datum before calling the subroutine. ! NC = NC + 1 UPLOS = UPLO NS = N ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 continue LDAS = LDA DO 20 I = 1, LX XS( I ) = XX( I ) 20 continue ! ! Call the subroutine. ! INCXS = INCX if ( FULL ) then call DSYR( UPLO, N, ALPHA, XX, INCX, AA, LDA ) else if ( PACKED ) then call DSPR( UPLO, N, ALPHA, XX, INCX, AA ) ! ! Check if error-exit was taken incorrectly. ! end if if ( NUMXER(NERR) /= 0 ) then if ( kprint >= 2 ) then write ( NOUT, FMT = 9992 ) end if FATAL = .TRUE. ! ! See what data changed inside subroutines. ! end if ISAME( 1 ) = UPLO == UPLOS ISAME( 2 ) = NS == N ISAME( 3 ) = ALS == ALPHA ISAME( 4 ) = LDE( XS, XX, LX ) ISAME( 5 ) = INCXS == INCX if ( NULL ) then ISAME( 6 ) = LDE( AS, AA, LAA ) else ISAME( 6 ) = LDERES( SNAME( 2: 3 ), UPLO, N, N, AS, & AA, LDA ) end if if ( .NOT.PACKED ) then ISAME( 7 ) = LDAS == LDA ! ! If data was incorrectly changed, report and return. ! end if DO 30 I = 1, NARGS if ( .NOT. ISAME( I ) ) then FATAL = .TRUE. if ( kprint >= 2 ) then write ( NOUT, FMT = 9998 )I end if end if ! 30 continue FTL = .FALSE. ! ! Check the result column by column. ! if ( .NOT.NULL ) then if ( INCX > 0 ) then DO 40 I = 1, N Z( I ) = X( I ) 40 continue else DO 50 I = 1, N Z( I ) = X( N - I + 1 ) 50 continue end if JA = 1 DO 60 J = 1, N W( 1 ) = Z( J ) if ( UPPER ) then JJ = 1 LJ = J else JJ = J LJ = N - J + 1 end if FTL = .FALSE. call DMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W, & 1, ONE, A( JJ, J ), 1, YT, G, & AA( JA ), EPS, ERR, FTL, NOUT, & .TRUE., kprint ) if ( FULL ) then if ( UPPER ) then JA = JA + LDA else JA = JA + LDA + 1 end if else JA = JA + LJ end if ERRMAX = max ( ERRMAX, ERR ) 60 continue end if if ( FTL ) then FATAL = .TRUE. if ( kprint >= 3 ) then write ( NOUT, FMT = 9995 )J write ( NOUT, FMT = 9996 )SNAME if ( FULL ) then write ( NOUT, FMT = 9993 )NC, & SNAME, UPLO, N, ALPHA, INCX, & LDA else if ( PACKED ) then write ( NOUT, FMT = 9994 )NC, & SNAME, UPLO, N, ALPHA, INCX end if end if ! end if ! 70 continue ! 80 continue ! 90 continue ! ! Report result. ! 100 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( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', & I2, ', AP) .' ) 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', & I2, ', A,', I3, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of DCHK52. ! '******' ) end subroutine DCHK53 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NBET, BET, NMAX, AB, AA, AS, BB, BS, C, CC, & !! DCHK53 !***SUBSIDIARY !***PURPOSE Test DSYR2K. !***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 DSYR2K. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED DMAKE3, DMMCH, DSYR2K, LDE, LDERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DCHK53 ! .. Parameters .. CS, CT, G, W) double precision ZERO ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0D0 ) LOGICAL FATAL double precision EPS, THRESH integer KPRINT, NALF, NBET, NIDIM, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME double precision AA( NMAX*NMAX ), AB( 2*NMAX*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 ), & G( NMAX ), W( 2*NMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ) double precision ALPHA, ALS, BETA, BETS, ERR, ERRMAX integer I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, & K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, & LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NERR, NS LOGICAL FTL, NULL, RESET, TRAN, UPPER CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS CHARACTER*2 ICHU ! .. Local Arrays .. CHARACTER*3 ICHT ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LDE, LDERES ! .. External Subroutines .. EXTERNAL LDE, LDERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL DSYR2K, DMAKE3, DMMCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN !***FIRST EXECUTABLE STATEMENT DCHK53 DATA ICHU/'UL'/, ICHT/'NTC'/ NARGS = 12 NC = 0 RESET = .TRUE. ! ERRMAX = ZERO DO 130 IN = 1, NIDIM ! Set LDC to 1 more than minimum value if room. N = IDIM( IN ) LDC = N if ( LDC < NMAX ) & ! Skip tests if not enough room. LDC = LDC + 1 if ( LDC > NMAX ) & GO TO 130 LCC = LDC*N ! NULL = N <= 0 DO 120 IK = 1, NIDIM ! K = IDIM( IK ) DO 110 ICT = 1, 3 TRANS = ICHT( ICT: ICT ) TRAN = TRANS == 'T'.OR.TRANS == 'C' if ( TRAN ) then MA = K NA = N else MA = N 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 110 ! ! Generate the matrix A. ! LAA = LDA*NA if ( TRAN ) then call DMAKE3( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, & LDA, RESET, ZERO ) else call DMAKE3('GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, & RESET, ZERO ) ! ! Generate the matrix B. ! end if LDB = LDA LBB = LAA if ( TRAN ) then call DMAKE3( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), & 2*NMAX, BB, LDB, RESET, ZERO ) else call DMAKE3( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), & NMAX, BB, LDB, RESET, ZERO ) ! end if DO 100 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) ! UPPER = UPLO == 'U' DO 90 IA = 1, NALF ! ALPHA = ALF( IA ) DO 80 IB = 1, NBET ! ! Generate the matrix C. ! BETA = BET( IB ) call DMAKE3( 'SY', UPLO, ' ', N, N, C, NMAX, CC, & ! LDC, RESET, ZERO ) ! ! Save every datum before calling the subroutine. ! NC = NC + 1 UPLOS = UPLO TRANSS = TRANS NS = N KS = K ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 continue LDAS = LDA DO 20 I = 1, LBB BS( I ) = BB( I ) 20 continue LDBS = LDB BETS = BETA DO 30 I = 1, LCC CS( I ) = CC( I ) 30 continue ! ! Call the subroutine. ! LDCS = LDC call DSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA, & ! ! Check if error-exit was taken incorrectly. ! BB, LDB, BETA, CC, LDC ) 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 ) = UPLOS == UPLO ISAME( 2 ) = TRANSS == TRANS ISAME( 3 ) = NS == N ISAME( 4 ) = KS == K ISAME( 5 ) = ALS == ALPHA ISAME( 6 ) = LDE( AS, AA, LAA ) ISAME( 7 ) = LDAS == LDA ISAME( 8 ) = LDE( BS, BB, LBB ) ISAME( 9 ) = LDBS == LDB ISAME( 10 ) = BETS == BETA if ( NULL ) then ISAME( 11 ) = LDE( CS, CC, LCC ) else ISAME( 11 ) = LDERES( 'SY', UPLO, N, N, CS, & CC, LDC ) end if ! ! If data was incorrectly changed, report and ! return. ! ISAME( 12 ) = 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 column by column. ! if ( .NOT.NULL ) then JJAB = 1 JC = 1 DO 70 J = 1, N if ( UPPER ) then JJ = 1 LJ = J else JJ = J LJ = N - J + 1 end if if ( TRAN ) then DO 50 I = 1, K W( I ) = AB( ( J - 1 )*2*NMAX + K + & I ) W( K + I ) = AB( ( J - 1 )*2*NMAX + & I ) 50 continue call DMMCH( 'T', 'N', LJ, 1, 2*K, & ALPHA, AB( JJAB ), 2*NMAX, & W, 2*NMAX, BETA, & C( JJ, J ), NMAX, CT, G, & CC( JC ), LDC, EPS, ERR, & FTL, NOUT, .TRUE., & kprint ) else DO 60 I = 1, K W( I ) = AB( ( K + I - 1 )*NMAX + & J ) W( K + I ) = AB( ( I - 1 )*NMAX + & J ) 60 continue call DMMCH( 'N', 'N', LJ, 1, 2*K, & ALPHA, AB( JJ ), NMAX, W, & 2*NMAX, BETA, C( JJ, J ), & NMAX, CT, G, CC( JC ), LDC, & EPS, ERR, FTL, NOUT, & .TRUE., kprint ) end if if ( UPPER ) then JC = JC + LDC else JC = JC + LDC + 1 if ( TRAN ) & JJAB = JJAB + 2*NMAX end if ERRMAX = max ( ERRMAX, ERR ) 70 continue end if if ( FTL ) then FATAL = .TRUE. if ( kprint >= 3 ) then write ( NOUT, FMT = 9996 )SNAME write ( NOUT, FMT = 9994 )NC, & SNAME, UPLO, TRANS, & N, K, ALPHA, LDA, LDB, & BETA, LDC end if ! end if ! 80 continue ! 90 continue ! 100 continue ! 110 continue ! 120 continue ! ! Report result. ! 130 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:' ) 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), & F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', & ' .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of DCHK53. ! '******' ) end subroutine DCHK62 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, & !! DCHK62 !***SUBSIDIARY !***PURPOSE Test DSYR2 and DSPR2. !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for DSYR2 and DSPR2. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED DMAKE2, DMVCH, DSPR2, DSYR2, LDE, LDERES, NUMXER !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DCHK62 ! .. Parameters .. Y, YY, YS, YT, G, Z) double precision ZERO, HALF, ONE ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) LOGICAL FATAL double precision EPS, THRESH integer INCMAX, KPRINT, NALF, NIDIM, NINC, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME double precision A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), & XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), & Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), & YY( NMAX*INCMAX ), Z( NMAX, 2 ) ! .. Local Scalars .. integer IDIM( NIDIM ), INC( NINC ) double precision ALPHA, ALS, ERR, ERRMAX, TRANSL integer I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX, & IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N, & NARGS, NC, NS, NERR LOGICAL FTL, FULL, NULL, PACKED, RESET, UPPER CHARACTER*1 UPLO, UPLOS ! .. Local Arrays .. CHARACTER*2 ICH double precision W( 2 ) ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LDE, LDERES ! .. External Subroutines .. EXTERNAL LDE, LDERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL DMAKE2, DMVCH, DSPR2, DSYR2 ! .. Data statements .. INTRINSIC ABS, MAX !***FIRST EXECUTABLE STATEMENT DCHK62 DATA ICH/'UL'/ FULL = SNAME( 3: 3 ) == 'Y' ! Define the number of arguments. PACKED = SNAME( 3: 3 ) == 'P' if ( FULL ) then NARGS = 9 else if ( PACKED ) then NARGS = 8 ! end if NC = 0 RESET = .TRUE. ERRMAX = ZERO DO 140 IN = 1, NIDIM ! Set LDA to 1 more than minimum value if room. N = IDIM( IN ) LDA = N if ( LDA < NMAX ) & ! Skip tests if not enough room. LDA = LDA + 1 if ( LDA > NMAX ) & GO TO 140 if ( PACKED ) then LAA = ( N*( N + 1 ) )/2 else LAA = LDA*N end if DO 130 IC = 1, 2 UPLO = ICH( IC: IC ) ! UPPER = UPLO == 'U' DO 120 IX = 1, NINC INCX = INC( IX ) ! ! Generate the vector X. ! LX = ABS( INCX )*N TRANSL = HALF call DMAKE2( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ), & 0, N - 1, RESET, TRANSL ) if ( N > 1 ) then X( N/2 ) = ZERO XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO ! end if DO 110 IY = 1, NINC INCY = INC( IY ) ! ! Generate the vector Y. ! LY = ABS( INCY )*N TRANSL = ZERO call DMAKE2( 'GE', ' ', ' ', 1, N, Y, 1, YY, & ABS( INCY ), 0, N - 1, RESET, TRANSL ) if ( N > 1 ) then Y( N/2 ) = ZERO YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO ! end if DO 100 IA = 1, NALF ALPHA = ALF( IA ) ! ! Generate the matrix A. ! NULL = N <= 0.OR.ALPHA == ZERO TRANSL = ZERO call DMAKE2( SNAME( 2: 3 ), UPLO, ' ', N, N, A, & NMAX, AA, LDA, N - 1, N - 1, RESET, & ! TRANSL ) ! ! Save every datum before calling the subroutine. ! NC = NC + 1 UPLOS = UPLO NS = N ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 continue LDAS = LDA DO 20 I = 1, LX XS( I ) = XX( I ) 20 continue INCXS = INCX DO 30 I = 1, LY YS( I ) = YY( I ) 30 continue ! ! Call the subroutine. ! INCYS = INCY if ( FULL ) then call DSYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, & AA, LDA ) else if ( PACKED ) then call DSPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, & AA ) ! ! Check if error-exit was taken incorrectly. ! end if if ( NUMXER(NERR) /= 0 ) then if ( kprint >= 2 ) then write ( NOUT, FMT = 9992 ) end if FATAL = .TRUE. ! ! See what data changed inside subroutines. ! end if ISAME( 1 ) = UPLO == UPLOS ISAME( 2 ) = NS == N ISAME( 3 ) = ALS == ALPHA ISAME( 4 ) = LDE( XS, XX, LX ) ISAME( 5 ) = INCXS == INCX ISAME( 6 ) = LDE( YS, YY, LY ) ISAME( 7 ) = INCYS == INCY if ( NULL ) then ISAME( 8 ) = LDE( AS, AA, LAA ) else ISAME( 8 ) = LDERES( SNAME( 2: 3 ), UPLO, N, N, & AS, AA, LDA ) end if if ( .NOT.PACKED ) then ISAME( 9 ) = LDAS == LDA ! ! 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 ! ! Check the result column by column. ! if ( .NOT.NULL ) then if ( INCX > 0 ) then DO 50 I = 1, N Z( I, 1 ) = X( I ) 50 continue else DO 60 I = 1, N Z( I, 1 ) = X( N - I + 1 ) 60 continue end if if ( INCY > 0 ) then DO 70 I = 1, N Z( I, 2 ) = Y( I ) 70 continue else DO 80 I = 1, N Z( I, 2 ) = Y( N - I + 1 ) 80 continue end if JA = 1 DO 90 J = 1, N W( 1 ) = Z( J, 2 ) W( 2 ) = Z( J, 1 ) if ( UPPER ) then JJ = 1 LJ = J else JJ = J LJ = N - J + 1 end if FTL = .FALSE. call DMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ), & NMAX, W, 1, ONE, A( JJ, J ), 1, & YT, G, AA( JA ), EPS, ERR, FTL, & NOUT, .TRUE., kprint ) if ( FULL ) then if ( UPPER ) then JA = JA + LDA else JA = JA + LDA + 1 end if else JA = JA + LJ end if ERRMAX = max ( ERRMAX, ERR ) if ( FTL ) then FATAL = .TRUE. if ( kprint >= 3 ) then write ( NOUT, FMT = 9995 )J write ( NOUT, FMT = 9996 )SNAME if ( FULL ) then write ( NOUT, FMT = 9993 )NC, & SNAME, UPLO, N, ALPHA, INCX, & INCY, LDA else if ( PACKED ) then write ( NOUT, FMT = 9994 )NC, & SNAME, UPLO, N, ALPHA, INCX, & INCY end if end if end if 90 continue ! end if ! 100 continue ! 110 continue ! 120 continue ! 130 continue ! ! Report result. ! 140 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( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', & I2, ', Y,', I2, ', AP) .' ) 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,', & I2, ', Y,', I2, ', A,', I3, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & ! ! End of DCHK62. ! '******' ) end !! DCHKE2 !***SUBSIDIARY !***PURPOSE Test the error exits from the Level 2 Blas. !***LIBRARY SLATEC (BLAS) !***AUTHOR Du Croz, J. J., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! Tests the error exits from the Level 2 Blas. ! ALPHA, BETA, A, X and Y should not need to be defined. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CHKXER, DGBMV, DGEMV, DGER, DSBMV, DSPMV, DSPR, ! DSPR2, DSYMV, DSYR, DSYR2, DTBMV, DTBSV, DTPMV, ! DTPSV, DTRMV, DTRSV, XERCLR, XERDMP, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DCHKE2 ! .. Scalar Arguments .. subroutine DCHKE2 (ISNUM, SRNAMT, NOUT, KPRINT, FATAL) integer ISNUM, NOUT LOGICAL FATAL CHARACTER*6 SRNAMT ! .. Local Scalars .. integer INFOT, KPRINT double precision ALPHA, BETA ! .. Local Arrays .. integer KONTRL ! .. External Subroutines .. double precision A( 1, 1), X( 1), Y( 1) EXTERNAL CHKXER, DGBMV, DGEMV, DGER, DSBMV, DSPMV, DSPR, & DSPR2, DSYMV, DSYR, DSYR2, DTBMV, DTBSV, DTPMV, & !***FIRST EXECUTABLE STATEMENT DCHKE2 DTPSV, DTRMV, DTRSV call XGETF (KONTRL) if ( kprint <= 2 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, & 90, 100, 110, 120, 130, 140, 150, & 160 )ISNUM 10 INFOT = 1 call xerclr call DGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call DGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 20 INFOT = 1 call xerclr call DGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call DGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call DGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 13 call xerclr call DGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 30 INFOT = 1 call xerclr call DSYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DSYMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DSYMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DSYMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call DSYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 40 INFOT = 1 call xerclr call DSBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DSBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DSBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DSBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call DSBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DSBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 50 INFOT = 1 call xerclr call DSPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DSPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DSPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DSPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 60 INFOT = 1 call xerclr call DTRMV( '/', 'N', 'N', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DTRMV( 'U', '/', 'N', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DTRMV( 'U', 'N', '/', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DTRMV( 'U', 'N', 'N', -1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRMV( 'U', 'N', 'N', 2, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call DTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 70 INFOT = 1 call xerclr call DTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DTBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DTBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DTBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DTBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 80 INFOT = 1 call xerclr call DTPMV( '/', 'N', 'N', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DTPMV( 'U', '/', 'N', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DTPMV( 'U', 'N', '/', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DTPMV( 'U', 'N', 'N', -1, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DTPMV( 'U', 'N', 'N', 0, A, X, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 90 INFOT = 1 call xerclr call DTRSV( '/', 'N', 'N', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DTRSV( 'U', '/', 'N', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DTRSV( 'U', 'N', '/', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DTRSV( 'U', 'N', 'N', -1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRSV( 'U', 'N', 'N', 2, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call DTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 100 INFOT = 1 call xerclr call DTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DTBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DTBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DTBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DTBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 110 INFOT = 1 call xerclr call DTPSV( '/', 'N', 'N', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DTPSV( 'U', '/', 'N', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DTPSV( 'U', 'N', '/', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DTPSV( 'U', 'N', 'N', -1, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DTPSV( 'U', 'N', 'N', 0, A, X, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 120 INFOT = 1 call xerclr call DGER( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DGER( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DGER( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DGER( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DGER( 2, 0, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 130 INFOT = 1 call xerclr call DSYR( '/', 0, ALPHA, X, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DSYR( 'U', -1, ALPHA, X, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DSYR( 'U', 0, ALPHA, X, 0, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DSYR( 'U', 2, ALPHA, X, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 140 INFOT = 1 call xerclr call DSPR( '/', 0, ALPHA, X, 1, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DSPR( 'U', -1, ALPHA, X, 1, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DSPR( 'U', 0, ALPHA, X, 0, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 150 INFOT = 1 call xerclr call DSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DSYR2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DSYR2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DSYR2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DSYR2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 160 INFOT = 1 call xerclr call DSPR2( '/', 0, ALPHA, X, 1, Y, 1, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DSPR2( 'U', -1, ALPHA, X, 1, Y, 1, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DSPR2( 'U', 0, ALPHA, X, 0, Y, 1, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DSPR2( 'U', 0, ALPHA, X, 1, Y, 0, A ) ! call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) 170 if ( kprint >= 2 ) then call XERDMP if ( .NOT.FATAL ) then write ( NOUT, FMT = 9999 )SRNAMT else write ( NOUT, FMT = 9998 )SRNAMT end if end if call XSETF (KONTRL) ! return 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', & ! ! End of DCHKE2. ! '**' ) end !! DCHKE3 !***SUBSIDIARY !***PURPOSE Test the error exits from the Level 3 Blas. !***LIBRARY SLATEC (BLAS) !***AUTHOR Dongarra, J. J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) !***DESCRIPTION ! ! Tests the error exits from the Level 3 Blas. ! ALPHA, BETA, A, X and Y should not need to be defined. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED CHKXER, DGEMM, DSYMM, DSYR2K, DSYRK, DTRMM, DTRSM, ! XERCLR, XERDMP, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DCHKE3 ! .. Scalar Arguments .. subroutine DCHKE3 (ISNUM, SRNAMT, NOUT, KPRINT, FATAL) LOGICAL FATAL integer ISNUM, NOUT CHARACTER*6 SRNAMT ! .. Local Scalars .. integer INFOT, KPRINT double precision ALPHA, BETA ! .. Local Arrays .. integer KONTRL ! .. External Subroutines .. double precision A( 1, 1), B( 1, 1), C( 1, 1) EXTERNAL CHKXER, DGEMM, DSYMM, DTRMM, DTRSM, DSYRK, & !***FIRST EXECUTABLE STATEMENT DCHKE3 DSYR2K call XGETF (KONTRL) if ( kprint <= 2 ) then call xsetf ( 0 ) else call xsetf ( 1 ) end if GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM 10 INFOT = 1 call xerclr call DGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 1 call xerclr call DGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call DGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call DGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call DGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call DGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call DGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call DGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call DGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call DGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 13 call xerclr call DGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 13 call xerclr call DGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 13 call xerclr call DGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 13 call xerclr call DGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 70 20 INFOT = 1 call xerclr call DSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 70 30 INFOT = 1 call xerclr call DTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 70 40 INFOT = 1 call xerclr call DTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call DTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call DTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call DTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 70 50 INFOT = 1 call xerclr call DSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DSYRK( 'U', '/', 0, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call DSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call DSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call DSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call DSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 70 60 INFOT = 1 call xerclr call DSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call DSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call DSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call DSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call DSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call DSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call DSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call DSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) ! call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) 70 if ( kprint >= 2 ) then call XERDMP if ( .NOT.FATAL ) then write ( NOUT, FMT = 9999 )SRNAMT else write ( NOUT, FMT = 9998 )SRNAMT end if end if call XSETF (KONTRL) ! return 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', & ! ! End of DCHKE3. ! '**' ) end !! DCMPAR !***PURPOSE Compare values in COMMON block DCHECK for quick check ! routine DPFITT. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (CMPARE-S, DCMPAR-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***COMMON BLOCKS DCHECK !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890921 Realigned order of variables in the COMMON block. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920214 Minor improvements to code for readability. (WRB) !***END PROLOGUE DCMPAR ! .. Scalar Arguments .. subroutine DCMPAR (ICNT, ITEST) ! .. Array Arguments .. integer ICNT ! .. Scalars in Common .. integer ITEST(9) double precision EPS, RP, SVEPS, TOL ! .. Arrays in Common .. integer IERP, IERR, NORD, NORDP ! .. Local Scalars .. double precision R(11) double precision RPP, SS ! .. Local Arrays .. integer IERPP, NRDP ! .. Intrinsic Functions .. integer ITEMP(4) ! .. Common blocks .. INTRINSIC ABS !***FIRST EXECUTABLE STATEMENT DCMPAR COMMON /DCHECK/ EPS, R, RP, SVEPS, TOL, NORDP, NORD, IERP, IERR ICNT = ICNT + 1 ITEMP(1) = 0 ITEMP(2) = 0 ITEMP(3) = 0 ITEMP(4) = 0 SS = SVEPS - EPS NRDP = NORDP - NORD RPP = RP - R(11) IERPP = IERP - IERR if ( ABS(SS) <= TOL .OR. ICNT <= 2 .OR. ICNT >= 6) ITEMP(1) = 1 if ( ABS(NRDP) == 0) ITEMP(2) = 1 if ( ICNT == 2) ITEMP(2) = 1 if ( ABS(RPP) <= TOL) ITEMP(3) = 1 ! ! Check to see if all four tests were good. ! If so, set the test number equal to 1. ! if ( ABS(IERPP) == 0) ITEMP(4) = 1 ITEST(ICNT) = ITEMP(1)*ITEMP(2)*ITEMP(3)*ITEMP(4) return end !! DDASQC !***PURPOSE Quick check for SLATEC routine DDASSL. !***LIBRARY SLATEC (DASSL) !***CATEGORY I1A2 !***TYPE DOUBLE PRECISION (SDASQC-S, DDASQC-D) !***KEYWORDS DDASSL, QUICK CHECK !***AUTHOR PETZOLD, LINDA R., (LLNL) ! COMPUTING AND MATHEMATICS RESEARCH DIVISION ! LAWRENCE LIVERMORE NATIONAL LABORATORY ! L - 316, P.O. BOX 808, ! LIVERMORE, CA. 94550 !***DESCRIPTION ! Demonstration program for DDASSL. ! ! DDASSL is used to solve two simple problems, ! one with a full Jacobian, the other with a banded Jacobian, ! with the 2 appropriate values of info(5) in each case. ! If the errors are too large, or other difficulty occurs, ! a warning message is printed. All output is on unit LUN. ! ! To run the demonstration problems with full print, call ! DDASQC with kprint = 3. ! !***REFERENCES (NONE) !***ROUTINES CALLED DDASSL, DDJAC1, DDJAC2, DDRES1, DDRES2, DEDIT2 !***REVISION HISTORY (YYMMDD) ! 851113 DATE WRITTEN ! 880608 Revised to meet new LDOC standards. ! 880615 Revised to meet new prologue standards. ! 891016 Converted to 4.0 format (FNF). ! 901001 Minor improvements to prologue. (FNF) ! 901003 Added some error prints and improved output formats. (FNF) ! 901009 Corrected GAMS classification code. (FNF) ! 901009 Changed AMAX1 to MAX. (FNF) ! 901009 Constructed double precision version. (FNF) ! 901030 Made all declarations explicit; added 1P's to formats. (FNF) !***END PROLOGUE DDASQC ! subroutine DDASQC (LUN, KPRINT, IPASS) ! integer LUN, KPRINT, IPASS ! EXTERNAL DDASSL, DDJAC1, DDJAC2, DDRES1, DDRES2, DEDIT2 integer I, IDID, INFO(15), IOUT, IPAR(1), IRES, IWORK(45), & J190, J290, LIW, LRW, ML, MU, NEQ, NERR, NFE, NJE, NOUT, & NQU, NST double precision & ATOL, DELTA(25), DTOUT, ER, ER1, ER2, ERM, ERO, HU, RPAR(1), & ! RTOL, RWORK(550), T, TOUT, TOUT1, Y(25), YPRIME(25), YT1, YT2 ! !***FIRST EXECUTABLE STATEMENT DDASQC DATA TOUT1/1.0D0/, DTOUT/1.0D0/ ipass = 1 NERR = 0 RTOL = 0.0D0 ATOL = 1.0D-3 LRW = 550 ! ! FIRST PROBLEM ! LIW = 45 NEQ = 2 NOUT = 10 if ( kprint >= 2) write (LUN,110) NEQ,RTOL,ATOL 110 FORMAT('1'/1X,' DEMONSTRATION PROGRAM FOR DDASSL',/// & 1X,' PROBLEM 1.. LINEAR DIFFERENTIAL/ALGEBRAIC SYSTEM..',/ & 1X,' X1DOT + 10.0*X1 = 0, X1 + X2 = 1',/ & 1X,' X1(0) = 1.0, X2(0) = 0.0',/ & 1X,' NEQ =',I2/ & 1X,' RTOL =',1P,D10.1,' ATOL =',D10.1) DO 190 J190 = 1,2 DO 115 I = 1,15 115 INFO(I) = 0 if ( J190 == 2) INFO(5) = 1 if ( kprint > 2) write (LUN,120) INFO(5) 120 FORMAT(////1X,' INFO(5) =',I3// & 6X,'T',15X,'X1',14X,'X2',12X,'NQ',6X,'H',12X/) T = 0.0D0 Y(1) = 1.0D0 Y(2) = 0.0D0 YPRIME(1) = -10.0D0 YPRIME(2) = 10.0D0 TOUT = TOUT1 ERO = 0.0D0 DO 170 IOUT = 1,NOUT call DDASSL(DDRES1,NEQ,T,Y,YPRIME,TOUT,INFO,RTOL,ATOL,IDID, & RWORK,LRW,IWORK,LIW,RPAR,IPAR,DDJAC1) HU = RWORK(7) NQU = IWORK(8) if ( kprint > 2 ) then write (LUN,140) T,Y(1),Y(2),NQU,HU end if 140 FORMAT(1X,1P,D15.5,D16.5,D16.5,I6,D14.3) if ( IDID < 0) GO TO 175 YT1 = EXP(-10.0D0*T) YT2 = 1.0D0 - YT1 ER1 = ABS(YT1 - Y(1)) ER2 = ABS(YT2 - Y(2)) ER = max ( ER1,ER2)/ATOL ERO = max ( ERO,ER) if ( ER > 1000.0D0) THEN if ( kprint >= 2) write (LUN,150) T 150 FORMAT(//' WARNING.. ERROR EXCEEDS 1000 * TOLERANCE', & ' WHEN T =',1P,D13.5//) NERR = NERR + 1 end if 170 TOUT = TOUT + DTOUT 175 continue if ( IDID < 0) THEN if ( kprint >= 2) write (LUN, 176) IDID, T 176 FORMAT (//'TROUBLE.. DDASSL RETURNED IDID =',I4, & ' WHEN T =',1P,D13.5) NERR = NERR + 1 end if NST = IWORK(11) NFE = IWORK(12) NJE = IWORK(13) if ( kprint > 2) write (LUN,180) NST,NFE,NJE,ERO 180 FORMAT(//1X,' FINAL STATISTICS FOR THIS RUN..',/ & 1X,' NUMBER OF STEPS =',I5/ & 1X,' NUMBER OF F-S =',I5/ & 1X,' NUMBER OF J-S =',I5/ & 1X,' ERROR OVERRUN =',1P,D10.2) ! ! SECOND PROBLEM ! 190 continue NEQ = 25 ML = 5 MU = 0 IWORK(1) = ML IWORK(2) = MU NOUT = 5 if ( kprint >= 2) write (LUN,210) NEQ,ML,MU,RTOL,ATOL 210 FORMAT('1'/1X,' DEMONSTRATION PROGRAM FOR DDASSL',/// & 1X,' PROBLEM 2.. YDOT = A * Y , WHERE ', & ' A IS A BANDED LOWER TRIANGULAR MATRIX',/ & 1X,' DERIVED FROM 2-D ADVECTION PDE',/ & 1X,' NEQ =',I3,' ML =',I2,' MU =',I2/ & 1X,' RTOL =',1P,D10.1,' ATOL =',D10.1) DO 290 J290 = 1,2 DO 215 I = 1,15 215 INFO(I) = 0 INFO(6) = 1 if ( J290 == 2) INFO(5) = 1 if ( kprint > 2) write (LUN,220) INFO(5) 220 FORMAT(////1X,' INFO(5) =',I3// & 6X,'T',14X,'MAX.ERR.',5X,'NQ',6X,'H'/) T = 0.0D0 DO 230 I = 2,NEQ 230 Y(I) = 0.0D0 Y(1) = 1.0D0 DO 235 I = 1,NEQ ! Following is to initialize YPRIME. 235 DELTA(I) = 0.0D0 call DDRES2(T,Y,DELTA,YPRIME,IRES,RPAR,IPAR) TOUT = 0.01D0 ERO = 0.0D0 DO 270 IOUT = 1,NOUT call DDASSL(DDRES2,NEQ,T,Y,YPRIME,TOUT,INFO,RTOL,ATOL,IDID, & RWORK,LRW,IWORK,LIW,RPAR,IPAR,DDJAC2) call DEDIT2(Y,T,ERM) HU = RWORK(7) NQU = IWORK(8) if ( kprint > 2) write (LUN,240) T,ERM,NQU,HU 240 FORMAT(1X,1P,D15.5,D14.3,I6,D14.3) if ( IDID < 0) GO TO 275 ER = ERM/ATOL ERO = max ( ERO,ER) if ( ER > 1000.0D0 ) then if ( kprint >= 2) write (LUN,150) T NERR = NERR + 1 end if 270 TOUT = TOUT*10.0D0 275 continue if ( IDID < 0) THEN if ( kprint >= 2) write (LUN, 176) IDID, T NERR = NERR + 1 end if NST = IWORK(11) NFE = IWORK(12) NJE = IWORK(13) if ( kprint > 2) write (LUN,180) NST,NFE,NJE,ERO 290 continue if ( kprint >= 2) write (LUN,300) NERR 300 FORMAT(////1X,' NUMBER OF ERRORS ENCOUNTERED =',I3) if ( NERR > 0 ) then ipass = 0 end if if ( (IPASS == 1) .and. (KPRINT > 1)) write (LUN,700) if ( (IPASS == 0) .and. (KPRINT /= 0)) write (LUN,800) 700 FORMAT (/,' ----------DDASSL PASSED ALL TESTS----------') 800 FORMAT (/,' **********DDASSL FAILED SOME TESTS*********') return end !! DDF !***SUBSIDIARY !***PURPOSE Quick check for SLATEC routines DDRIV1, DDRIV2 and DDRIV3. !***LIBRARY SLATEC (SDRIVE) !***CATEGORY I1A2, I1A1B !***TYPE DOUBLE PRECISION (SDF-S, DDF-D, CDF-C) !***KEYWORDS DDRIV1, DDRIV2, DDRIV3, QUICK CHECK, SDRIVE !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***SEE ALSO DDQCK !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 890405 DATE WRITTEN ! 890405 Revised to meet SLATEC standards. !***END PROLOGUE DDF subroutine DDF (N, T, Y, YP) double precision ALFA, T, Y(*), YP(*) !***FIRST EXECUTABLE STATEMENT DDF integer N ALFA = Y(N+1) YP(1) = 1.D0 + ALFA*(Y(2) - Y(1)) - Y(1)*Y(3) YP(2) = ALFA*(Y(1) - Y(2)) - Y(2)*Y(3) YP(3) = 1.D0 - Y(3)*(Y(1) + Y(2)) return end !! DDJAC1 !***SUBSIDIARY !***PURPOSE First Jacobian evaluator for DDASQC. !***LIBRARY SLATEC (DASSL) !***TYPE DOUBLE PRECISION (SDJAC1-S, DDJAC1-D) !***AUTHOR PETZOLD, LINDA R., (LLNL) !***SEE ALSO DDASQC !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 891013 DATE WRITTEN ! 901001 Converted prologue to 4.0 format and made all argument ! declarations explicit. (FNF) !***END PROLOGUE DDJAC1 subroutine DDJAC1 (T, Y, YPRIME, PD, CJ, RPAR, IPAR) integer IPAR(*) !***FIRST EXECUTABLE STATEMENT DDJAC1 double precision T, Y(*), YPRIME(*), PD(2,2), CJ, RPAR(*) PD(1,1) = CJ + 10.0D0 PD(1,2) = 0.0D0 PD(2,1) = 1.0D0 PD(2,2) = 1.0D0 return end !! DDJAC2 !***SUBSIDIARY !***PURPOSE Second Jacobian evaluator for DDASQC. !***LIBRARY SLATEC (DASSL) !***TYPE DOUBLE PRECISION (SDJAC2-S, DDJAC2-D) !***AUTHOR PETZOLD, LINDA R., (LLNL) !***SEE ALSO DDASQC !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 891013 DATE WRITTEN ! 901001 Converted prologue to 4.0 format and made all argument ! declarations explicit. (FNF) ! 901001 Eliminated 7-character variable names MBANDPn by explicitly ! including MBAND+n in expressions. (FNF) ! 901030 Made all local declarations explicit. (FNF) !***END PROLOGUE DDJAC2 subroutine DDJAC2 (T, Y, YPRIME, PD, CJ, RPAR, IPAR) integer IPAR(*) double precision T, Y(*), YPRIME(*), PD(11,25), CJ, RPAR(*) integer J, MBAND, ML, MU, NEQ, NG double precision ALPH1, ALPH2 DATA ALPH1/1.0D0/, ALPH2/1.0D0/, NG/5/ !***FIRST EXECUTABLE STATEMENT DDJAC2 DATA ML/5/, MU/0/, NEQ/25/ MBAND = ML + MU + 1 DO 10 J = 1,NEQ PD(MBAND,J) = -2.0D0 - CJ PD(MBAND+1,J) = ALPH1 PD(MBAND+2,J) = 0.0D0 PD(MBAND+3,J) = 0.0D0 PD(MBAND+4,J) = 0.0D0 10 PD(MBAND+5,J) = ALPH2 DO 20 J = 1,NEQ,NG 20 PD(MBAND+1,J) = 0.0D0 return end !! DDQCK !***PURPOSE Quick check for SLATEC routines DDRIV1, DDRIV2 and DDRIV3. !***LIBRARY SLATEC (SDRIVE) !***CATEGORY I1A2, I1A1B !***TYPE DOUBLE PRECISION (SDQCK-S, DDQCK-D, CDQCK-C) !***KEYWORDS DDRIV1, DDRIV2, DDRIV3, QUICK CHECK, SDRIVE !***AUTHOR Kahaner, D. K., (NIST) ! National Institute of Standards and Technology ! Gaithersburg, MD 20899 ! Sutherland, C. D., (LANL) ! Mail Stop D466 ! Los Alamos National Laboratory ! Los Alamos, NM 87545 !***DESCRIPTION ! ! For assistance in determining the cause of a failure of these ! routines contact C. D. Sutherland at commercial telephone number ! (505)667-6949, FTS telephone number 8-843-6949, or electronic mail ! address CDS@LANL.GOV . ! !***ROUTINES CALLED d1mach, DDF, DDRIV1, DDRIV2, DDRIV3, XERCLR !***REVISION HISTORY (YYMMDD) ! 890405 DATE WRITTEN ! 890405 Revised to meet SLATEC standards. !***END PROLOGUE DDQCK subroutine DDQCK (LUN, KPRINT, IPASS) EXTERNAL DDF double precision ALFA, EPS, EWT(1), HMAX, d1mach, T, TOUT integer IERFLG, IERROR, IMPL, IPASS, KPRINT, LENIW, LENIWX, LENW, & LENWMX, LENWX, LIWMX, LUN, MINT, MITER, ML, MSTATE, MU, & MXORD, MXSTEP, N, NDE, NFE, NJE, NROOT, NSTATE, NSTEP, & NTASK, NX PARAMETER(ALFA = 1.D0, HMAX = 15.D0, IERROR = 3, IMPL = 0, & LENWMX = 342, LIWMX = 53, MITER = 5, ML = 2, MU = 2, & MXORD = 5, MXSTEP = 1000, N = 3, NROOT = 0, NTASK = 1) double precision WORK(LENWMX), Y(N+1) integer IWORK(LIWMX) !***FIRST EXECUTABLE STATEMENT DDQCK DATA EWT(1) /.00001D0/ EPS = d1mach(4)**(1.D0/3.D0) ! Exercise DDRIV1 for problem ! with known solution. ipass = 1 Y(4) = ALFA T = 0.D0 Y(1) = 10.D0 Y(2) = 0.D0 Y(3) = 10.D0 TOUT = 10.D0 MSTATE = 1 LENW = 342 call DDRIV1 (N, T, Y, DDF, TOUT, MSTATE, EPS, WORK, LENW, IERFLG) NSTEP = WORK(LENW - (N + 50) + 3) NFE = WORK(LENW - (N + 50) + 4) NJE = WORK(LENW - (N + 50) + 5) if ( MSTATE == 2 ) then if ( ABS(1.D0 - Y(1)*1.5D0) <= EPS**(2.D0/3.D0) .and. & ABS(1.D0 - Y(2)*3.D0) <= EPS**(2.D0/3.D0) .and. & ABS(1.D0 - Y(3)) <= EPS**(2.D0/3.D0) ) then if ( kprint == 2 ) then write (LUN, '('' DDRIV1:The solution determined met the expected values.'' //)') else if ( kprint == 3 ) then write (LUN, '('' DDRIV1:The solution determined met the expected values.'')') write (LUN, '('' The values of results are '')') write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, '(/)') end if else if ( kprint == 1 ) then write (LUN, '('' DDRIV1:The solution determined is not accurate enough.'' //)') else if ( kprint == 2 ) then write (LUN, '('' DDRIV1:The solution determined is not accurate enough.'')') write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) ' EPS = ', EPS write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(//)') end if ipass = 0 end if else if ( kprint == 1 ) then write (LUN, '('' While using DDRIV1, a solution was not obtained.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' While using DDRIV1, a solution was not obtained.'')') write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) & ' MSTATE = ', MSTATE, ', Error number = ', IERFLG write (LUN, *) ' N ', N, ', EPS ', EPS, ', LENW ', LENW write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(//)') end if ipass = 0 end if ! Run DDRIV1 with invalid input. call xerclr NX = 201 T = 0.D0 Y(1) = 10.D0 Y(2) = 0.D0 Y(3) = 10.D0 Y(4) = ALFA TOUT = 10.D0 MSTATE = 1 LENW = 342 call DDRIV1 (NX, T, Y, DDF, TOUT, MSTATE, EPS, WORK, LENW, IERFLG) if ( IERFLG == 21 ) then if ( kprint == 2 ) then write (LUN, '('' DDRIV1:An invalid parameter has been correctly detected.'' //)') else if ( kprint == 3 ) then write (LUN, '('' DDRIV1:An invalid parameter has been correctly detected.'')') write (LUN, *) ' The value of N was set to ', NX write (LUN, *) & ' MSTATE = ', MSTATE, ', Error number = ', IERFLG write (LUN, '(/)') end if else if ( kprint == 1 ) then write (LUN, '('' DDRIV1:An invalid parameter has not been correctly detected.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' DDRIV1:An invalid parameter has not been correctly detected.'')') write (LUN, *) ' The value of N was set to ', NX write (LUN, *) & ' MSTATE = ', MSTATE, ', Error number = ', IERFLG write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) ' EPS ', EPS, ', LENW ', LENW write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(//)') end if ipass = 0 end if ! Exercise DDRIV2 for problem ! with known solution. call xerclr T = 0.D0 Y(1) = 10.D0 Y(2) = 0.D0 Y(3) = 10.D0 Y(4) = ALFA MSTATE = 1 TOUT = 10.D0 MINT = 1 LENW = 298 LENIW = 50 call DDRIV2 (N, T, Y, DDF, TOUT, MSTATE, NROOT, EPS, EWT, & MINT, WORK, LENW, IWORK, LENIW, DDF, IERFLG) NSTEP = IWORK(3) NFE = IWORK(4) NJE = IWORK(5) if ( MSTATE == 2 ) then if ( ABS(1.D0 - Y(1)*1.5D0) <= EPS**(2.D0/3.D0) .and. & ABS(1.D0 - Y(2)*3.D0) <= EPS**(2.D0/3.D0) .and. & ABS(1.D0 - Y(3)) <= EPS**(2.D0/3.D0) ) then if ( kprint == 2 ) then write (LUN, '('' DDRIV2:The solution determined met the expected values.'' //)') else if ( kprint == 3 ) then write (LUN, '('' DDRIV2:The solution determined met the expected values.'')') write (LUN, '('' The values of results are '')') write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, '(/)') end if else if ( kprint == 1 ) then write (LUN, '('' DDRIV2:The solution determined is not accurate enough.'' //)') else if ( kprint == 2 ) then write (LUN, '('' DDRIV2:The solution determined is not accurate enough.'')') write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) ' EPS = ', EPS, ', EWT = ', EWT write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(//)') end if ipass = 0 end if else if ( kprint == 1 ) then write (LUN, '('' While using DDRIV2, a solution was not obtained.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' While using DDRIV2, a solution was not obtained.'')') write (LUN, *) & ' MSTATE = ', MSTATE, ', Error number = ', IERFLG write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) ' EPS = ', EPS, ', EWT ', EWT write (LUN, *) & ' MINT = ', MINT, ', LENW ', LENW, ', LENIW ', LENIW write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(//)') end if ipass = 0 end if ! Run DDRIV2 with invalid input. call xerclr T = 0.D0 Y(1) = 10.D0 Y(2) = 0.D0 Y(3) = 10.D0 Y(4) = ALFA TOUT = 10.D0 MSTATE = 1 MINT = 1 LENWX = 1 LENIW = 50 call DDRIV2 (N, T, Y, DDF, TOUT, MSTATE, NROOT, EPS, EWT, & MINT, WORK, LENWX, IWORK, LENIW, DDF, IERFLG) if ( IERFLG == 32 ) then if ( kprint == 2 ) then write (LUN, '('' DDRIV2:An invalid parameter has been correctly detected.'' //)') else if ( kprint == 3 ) then write (LUN, '('' DDRIV2:An invalid parameter has been correctly detected.'')') write (LUN, *) & ' The value of LENW was set to ', LENWX write (LUN, *) & ' MSTATE = ', MSTATE, ', Error number = ', IERFLG write (LUN, '(/)') end if else if ( kprint == 1 ) then write (LUN, '('' DDRIV2:An invalid parameter has not been correctly detected.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' DDRIV2:An invalid parameter has not been correctly detected.'')') write (LUN, *) ' The value of LENW was set to ', LENWX write (LUN, *) & ' MSTATE = ', MSTATE, ', Error number = ', IERFLG write (LUN, '('' The values of parameters, results, and tatistical quantities are:'')') write (LUN, *) & ' EPS ', EPS, ', MINT ', MINT, ', LENW ', LENW, & ', LENIW ', LENIW write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(//)') end if ipass = 0 end if ! Exercise DDRIV3 for problem ! with known solution. call xerclr T = 0.D0 Y(1) = 10.D0 Y(2) = 0.D0 Y(3) = 10.D0 Y(4) = ALFA NSTATE = 1 TOUT = 10.D0 MINT = 2 LENW = 301 LENIW = 53 call DDRIV3 (N, T, Y, DDF, NSTATE, TOUT, NTASK, NROOT, EPS, EWT, & IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, & WORK, LENW, IWORK, LENIW, DDF, DDF, NDE, & MXSTEP, DDF, DDF, IERFLG) NSTEP = IWORK(3) NFE = IWORK(4) NJE = IWORK(5) if ( NSTATE == 2 ) then if ( ABS(1.D0 - Y(1)*1.5D0) <= EPS**(2.D0/3.D0) .and. & ABS(1.D0 - Y(2)*3.D0) <= EPS**(2.D0/3.D0) .and. & ABS(1.D0 - Y(3)) <= EPS**(2.D0/3.D0) ) then if ( kprint == 2 ) then write (LUN, '('' DDRIV3:The solution determined met the expected values.'' //)') else if ( kprint == 3 ) then write (LUN, '('' DDRIV3:The solution determined met the expected values.'')') write (LUN, '('' The values of results are '')') write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, '(/)') end if else if ( kprint == 1 ) then write (LUN, '('' DDRIV3:The solution determined is not accurate enough.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' DDRIV3:The solution determined is not accurate enough.'')') write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) & ' EPS = ', EPS, ', EWT = ', EWT, ', IERROR = ', IERROR write (LUN, *) & ' MINT = ', MINT, ', MITER = ', MITER, ', IMPL = ', IMPL write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(//)') end if ipass = 0 end if else if ( kprint == 1 ) then write (LUN, '('' While using DDRIV3, a solution was not obtained.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' While using DDRIV3, a solution was not obtained.'')') write (LUN, *) & ' MSTATE = ', MSTATE, ', Error number = ', IERFLG write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) & ' EPS = ', EPS, ', EWT = ', EWT, ', IERROR = ', IERROR write (LUN, *) & ' MINT = ', MINT, ', MITER = ', MITER, ', IMPL = ', IMPL write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(//)') end if ipass = 0 end if ! Run DDRIV3 with invalid input. call xerclr T = 0.D0 Y(1) = 10.D0 Y(2) = 0.D0 Y(3) = 10.D0 Y(4) = ALFA NSTATE = 1 TOUT = 10.D0 MINT = 2 LENW = 301 LENIWX = 1 call DDRIV3 (N, T, Y, DDF, NSTATE, TOUT, NTASK, NROOT, EPS, & EWT, IERROR, MINT, MITER, IMPL, ML, MU, & MXORD, HMAX, WORK, LENW, IWORK, LENIWX, DDF, & DDF, NDE, MXSTEP, DDF, DDF, IERFLG) if ( IERFLG == 33 ) then if ( kprint == 2 ) then write (LUN, '('' DDRIV3:An invalid parameter has been correctly detected.'' //)') else if ( kprint == 3 ) then write (LUN, '('' DDRIV3:An invalid parameter has been correctly detected.'')') write (LUN, *) & ' The value of LENIW was set to ', LENIWX write (LUN, *) & ' NSTATE = ', NSTATE, ', Error number = ', IERFLG write (LUN, '(/)') end if else if ( kprint == 1 ) then write (LUN, '('' DDRIV3:An invalid parameter has not been correctly detected.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' DDRIV3:An invalid parameter has not been correctly detected.'')') write (LUN, *) & ' The value of LENIW was set to ', LENIWX write (LUN, *) & ' NSTATE = ', NSTATE, ', Error number = ', IERFLG write (LUN, '('' The values of parameters, results, and statistical quantities are:'')') write (LUN, *) & ' EPS = ', EPS, ', EWT = ', EWT, ', IERROR = ', IERROR write (LUN, *) & ' MINT = ', MINT, ', MITER = ', MITER, ', IMPL = ', IMPL write (LUN, *) ' T ', T write (LUN, *) ' Y(1) ', Y(1) write (LUN, *) ' Y(2) ', Y(2) write (LUN, *) ' Y(3) ', Y(3) write (LUN, *) & ' Number of steps taken is ', NSTEP write (LUN, *) & ' Number of evaluations of the right hand side is ', NFE write (LUN, *) & ' Number of evaluations of the Jacobian matrix is ', NJE write (LUN, '(//)') end if ipass = 0 end if call xerclr return end !! DDRES1 !***SUBSIDIARY !***PURPOSE First residual evaluator for DDASQC. !***LIBRARY SLATEC (DASSL) !***TYPE DOUBLE PRECISION (SDRES1-S, DDRES1-D) !***AUTHOR PETZOLD, LINDA R., (LLNL) !***SEE ALSO DDASQC !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 891013 DATE WRITTEN ! 901001 Converted prologue to 4.0 format and made all argument ! declarations explicit. (FNF) !***END PROLOGUE DDRES1 subroutine DDRES1 (T, Y, YPRIME, DELTA, IRES, RPAR, IPAR) integer IRES, IPAR(*) !***FIRST EXECUTABLE STATEMENT DDRES1 double precision T, Y(*), YPRIME(*), DELTA(*), RPAR(*) DELTA(1) = YPRIME(1) + 10.0D0*Y(1) DELTA(2) = Y(2) + Y(1) - 1.0D0 return end !! DDRES2 !***SUBSIDIARY !***PURPOSE Second residual evaluator for DDASQC. !***LIBRARY SLATEC (DASSL) !***TYPE DOUBLE PRECISION (SDRES2-S, DDRES2-D) !***AUTHOR PETZOLD, LINDA R., (LLNL) !***SEE ALSO DDASQC !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 891013 DATE WRITTEN ! 901001 Converted prologue to 4.0 format and made all argument ! declarations explicit. (FNF) ! 901030 Made all local declarations explicit. (FNF) !***END PROLOGUE DDRES2 subroutine DDRES2 (T, Y, YPRIME, DELTA, IRES, RPAR, IPAR) integer IRES, IPAR(*) double precision T, Y(*), YPRIME(*), DELTA(*), RPAR(*) integer I, J, K, NG double precision ALPH1, ALPH2, D !***FIRST EXECUTABLE STATEMENT DDRES2 DATA ALPH1/1.0D0/, ALPH2/1.0D0/, NG/5/ DO 10 J = 1,NG DO 10 I = 1,NG K = I + (J - 1)*NG D = -2.0D0*Y(K) if ( I /= 1) D = D + Y(K-1)*ALPH1 if ( J /= 1) D = D + Y(K-NG)*ALPH2 10 DELTA(K) = D - YPRIME(K) return end !! DEDIT2 !***SUBSIDIARY !***PURPOSE Subsidiary to DDASQC. !***LIBRARY SLATEC (DASSL) !***TYPE DOUBLE PRECISION (EDIT2-S, DEDIT2-D) !***AUTHOR PETZOLD, LINDA R., (LLNL) !***SEE ALSO DDASQC !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 891013 DATE WRITTEN ! 901001 Converted prologue to 4.0 format and made all argument ! declarations explicit. (FNF) ! 901009 Changed AMAX1 to MAX. (FNF) ! 901030 Removed FLOAT's; made all local declarations explicit. (FNF) !***END PROLOGUE DEDIT2 subroutine DEDIT2 (Y, T, ERM) double precision Y(*), T, ERM integer I, J, K, NG double precision ALPH1, ALPH2, A1, A2, ER, EX, YT !***FIRST EXECUTABLE STATEMENT DEDIT2 DATA ALPH1/1.0D0/, ALPH2/1.0D0/, NG/5/ ERM = 0.0D0 if ( T == 0.0D0) RETURN EX = 0.0D0 if ( T <= 30.0D0) EX = EXP(-2.0D0*T) A2 = 1.0D0 DO 60 J = 1,NG A1 = 1.0D0 DO 50 I = 1,NG K = I + (J - 1)*NG YT = T**(I+J-2)*EX*A1*A2 ER = ABS(Y(K)-YT) ERM = max ( ERM,ER) A1 = A1*ALPH1/I 50 continue A2 = A2*ALPH2/J 60 continue return end !! DEG8CK !***PURPOSE Quick check for DEXINT and DGAUS8. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (EG8CK-S, DEG8CK-D) !***KEYWORDS QUICK CHECK !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! DEG8CK is a quick check routine for DEXINT and DGAUS8. Exponential ! integrals from DEXINT are checked against quadratures from DGAUS8. ! !***ROUTINES CALLED d1mach, DEXINT, DFEIN, DGAUS8 !***COMMON BLOCKS DFEINX !***REVISION HISTORY (YYMMDD) ! 800501 DATE WRITTEN ! 890718 Added check when testing error conditions. (WRB) ! 890718 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 910708 Code revised to test error returns for all values of ! KPRINT. (WRB) ! 920206 Corrected argument list in call to DEXINT. (WRB) !***END PROLOGUE DEG8CK subroutine DEG8CK (LUN, KPRINT, IPASS) COMMON /DFEINX/ X, A, FKM integer I, ICASE, IE, IERR, II, IK, IPASS, IX, IY, K, KE, KK, & KODE, KX, LUN, M, N, NM, NZ double precision A, ANS, ATOL, BB, EN, ER, EX, FKM, SIG, SUM, & TOL, T1, T2, X, XX, Y double precision d1mach, DFEIN dimension EN(4), Y(4), XX(5) LOGICAL FATAL !***FIRST EXECUTABLE STATEMENT DEG8CK EXTERNAL DFEIN if ( kprint >= 2) write (LUN, 90000) IPASS=1 TOL = SQRT(MAX(d1mach(4),1.0D-18)) DO 150 KODE=1,2 IK = KODE - 1 FKM = IK DO 140 N=1,25,8 DO 130 M=1,4 NM = N + M - 1 DO 120 IX=1,25,8 X = IX- 0.20D0 call DEXINT(X, N, KODE, M, TOL, EN, NZ, IERR) KX = X+0.5D0 if ( KX == 0) KX = 1 ICASE = 1 A = N if ( KX <= N) GO TO 10 ICASE = 2 A = NM if ( KX >= NM) GO TO 10 ICASE = 3 A = KX 10 continue SIG = 3.0D0/X T2 = 1.0D0 SUM = 0.0D0 20 continue T1 = T2 T2 = T2 + SIG ATOL = TOL call DGAUS8(DFEIN, T1, T2, ATOL, ANS, IERR) SUM = SUM + ANS if ( ABS(ANS) < ABS(SUM)*TOL) GO TO 30 GO TO 20 30 continue EX = 1.0D0 if ( KODE == 1) EX = EXP(-X) BB = A if ( ICASE /= 3) GO TO 40 IY = KX - N + 1 Y(IY) = SUM KE = M - IY IE = IY - 1 KK = IY II = IY GO TO 60 40 continue if ( ICASE /= 2) GO TO 50 Y(M) = SUM if ( M == 1) GO TO 100 IE = M - 1 II = M GO TO 80 50 continue Y(1) = SUM if ( M == 1) GO TO 100 KE = M - 1 KK = 1 ! ! Forward recur ! 60 continue DO 70 K=1,KE Y(KK+1) = (EX-X*Y(KK))/BB BB = BB + 1.0D0 KK = KK + 1 70 continue if ( ICASE /= 3) GO TO 100 ! ! Backward recur ! 80 BB = A - 1.0D0 DO 90 I=1,IE Y(II-1) = (EX-BB*Y(II))/X BB = BB - 1.0D0 II = II - 1 90 continue 100 continue DO 110 I=1,M ER = ABS((Y(I)-EN(I))/Y(I)) if ( ER > TOL ) then write (LUN,90010) ipass = 0 GO TO 160 end if 110 continue 120 continue 130 continue 140 continue ! ! Trigger 6 error conditions. ! 150 continue ! 160 FATAL = .FALSE. if ( kprint >= 3) write (LUN, 90020) XX(1) = 1.0D0 XX(2) = 1.0D0 XX(3) = 1.0D0 XX(4) = 1.0D0 XX(5) = 0.01D0 DO 170 I=1,5 XX(I) = -XX(I) K = XX(2) N = XX(3) M = XX(4) call DEXINT (XX(I), N, K, M, XX(5), EN, NZ, IERR) if ( IERR /= 1 ) then ipass = 0 FATAL = .TRUE. write (LUN, 90030) I end if XX(I) = -XX(I) 170 continue X = 0.0D0 TOL = 1.0D-2 call DEXINT (X, 1, 1, 1, TOL, EN, NZ, IERR) if ( IERR /= 1 ) then ipass = 0 FATAL = .TRUE. write (LUN, 90040) end if 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 ('1' / ' QUICK CHECK FOR DEXINT AND DGAUS8' /) 90010 FORMAT (// ' ERROR IN DEG8CK COMPARISON TEST' /) 90020 FORMAT (/ ' TRIGGER 6 ERROR CONDITIONS' /) 90030 FORMAT (' Error occurred with DO index I =', I2) 90040 FORMAT (' Error occurred with X = 0.0') 90070 FORMAT (/' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 90080 FORMAT (/' ALL INCORRECT ARGUMENT TESTS PASSED') 90100 FORMAT (/ ' *********DEXINT AND DGAUS8 PASSED ALL TESTS*********') 90110 FORMAT (/ ' *********DEXINT OR DGAUS8 FAILED SOME TESTS*********') end !! DEVCHK !***SUBSIDIARY !***PURPOSE Test evaluation accuracy of DCHFDV and DCHFEV for DPCHQ1. !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (EVCHCK-S, DEVCHK-D) !***KEYWORDS PCHIP EVALUATOR QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! -------- CODE TO TEST EVALUATION ACCURACY OF DCHFDV AND DCHFEV ------- ! ! USING FUNCTION AND DERIVATIVE VALUES FROM A CUBIC (COMPUTED IN ! DOUBLE PRECISION) AT NINT DIFFERENT (X1,X2) PAIRS: ! 1. CHECKS THAT DCHFDV AND DCHFEV BOTH REPRODUCE ENDPOINT VALUES. ! 2. EVALUATES AT NPTS POINTS, 10 OF WHICH ARE OUTSIDE THE INTERVAL ! AND: ! A. CHECKS ACCURACY OF DCHFDV FUNCTION AND DERIVATIVE VALUES ! AGAINST EXACT VALUES. ! B. CHECKS THAT RETURNED VALUES OF NEXT SUM TO 10. ! C. CHECKS THAT FUNCTION VALUES FROM DCHFEV AGREE WITH THOSE ! FROM DCHFDV. ! ! ! FORTRAN INTRINSICS USED: ABS, MAX, MIN. ! FORTRAN LIBRARY ROUTINES USED: SQRT, (READ), (WRITE). ! SLATEC LIBRARY ROUTINES USED: DCHFDV, DCHFEV, d1mach, RAND. ! OTHER ROUTINES USED: DFDTRU. ! !***ROUTINES CALLED d1mach, DCHFDV, DCHFEV, DFDTRU, RAND !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 820624 CONVERTED TO QUICK CHECK FOR SLATEC LIBRARY. ! 820630 1. MODIFIED DEFINITIONS OF RELATIVE ERROR AND TEST ! TOLERANCES. ! 2. VARIOUS IMPROVEMENTS TO OUTPUT FORMATS. ! 820716 1. SET MACHEP VIA A call TO d1mach. ! 2. CHANGED FROM FORTLIB'S RANF TO SLATEC'S RAND. ! 890628 1. Removed unnecessary IMPLICIT declaration. ! 2. Removed unnecessary variable NEV. ! 3. Other changes to reduce S.P./D.P. differences. ! 890629 Added RERR to DOUBLE PRECISION declaration. ! 890706 Cosmetic changes to prologue. (WRB) ! 890831 Modified array declarations. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 Revised prologue and improved some output formats. (FNF) ! Also moved formats to end to be consistent with other PCHIP ! quick checks. ! 900316 Additional minor cosmetic changes. (FNF) ! 900321 Changed name of DFTRUE to DFDTRU and made additional minor ! cosmetic changes. (FNF) ! 901130 Added 1P's to formats and revised some to reduce maximum ! line length. (FNF) ! 910708 Minor modifications in use of KPRINT. (WRB) ! 910801 Added EXTERNAL statement for RAND due to problem on IBM ! RS 6000. (WRB) ! 910819 Changed argument to RAND function from a D.P. zero to a ! S.P. zero. (WRB) !***END PROLOGUE DEVCHK ! ! Declare arguments. ! subroutine DEVCHK (LOUT, KPRINT, NPTS, XEV, FEV, DEV, FEV2, FAIL) integer LOUT, KPRINT, NPTS double precision XEV(*), FEV(*), DEV(*), FEV2(*) ! ! DECLARATIONS. ! LOGICAL FAIL integer I, IERR, IINT, NEXT(2), NEXT2(2), NINT double precision & AED, AED2, AEDMAX, AEDMIN, AEF, AEF2, AEFMAX, AEFMIN, & CHECK(2), CHECKF(2), CHECKD(2), D1, D2, DERMAX, DTRUE, DX, & EPS1, EPS2, F1, F2, FACT, FERMAX, FLOORD, FLOORF, FOUR, & FTRUE, LEFT(3), MACHEP, & ONE, RED, RED2, REDMAX, REDMIN, REF, REF2, REFMAX, & REFMIN, RIGHT(3), SMALL, TEN, TOL1, TOL2, & X1, X2, XADMAX, XADMIN, XAFMAX, XAFMIN, XRDMAX, & XRDMIN, XRFMAX, XRFMIN, ZERO ! LOGICAL FAILOC, FAILNX ! The following should stay REAL (no D.P. equivalent). double precision d1mach REAL RAND ! ! DEFINE RELATIVE ERROR WITH FLOOR. ! EXTERNAL RAND double precision RERR, ERR, VALUE, FLOOR ! ! INITIALIZE. ! RERR(ERR,VALUE,FLOOR) = ERR / max ( ABS(VALUE), FLOOR) DATA ZERO /0.D0/, ONE /1.D0/, FOUR /4.D0/, TEN /10.D0/ DATA SMALL /1.0D-10/ DATA NINT /3/ DATA LEFT /-1.5D0, 2.0D-10, 1.0D0 / ! !***FIRST EXECUTABLE STATEMENT DEVCHK DATA RIGHT / 2.5D0, 3.0D-10, 1.0D+8/ MACHEP = d1mach(4) EPS1 = FOUR*MACHEP ! EPS2 = TEN*MACHEP ! FAIL = .FALSE. ! ! CYCLE OVER INTERVALS. ! if ( kprint >= 2) write (LOUT, 3000) DO 90 IINT = 1, NINT X1 = LEFT(IINT) ! X2 = RIGHT(IINT) FACT = max ( SQRT(X2-X1), ONE) TOL1 = EPS1 * FACT ! ! COMPUTE AND PRINT ENDPOINT VALUES. ! TOL2 = EPS2 * FACT call DFDTRU (X1, F1, D1) ! call DFDTRU (X2, F2, D2) if ( kprint >= 3) THEN if ( IINT == 1) write (LOUT, 2000) write (LOUT, '(/)') write (LOUT, 2001) 'X1', X1, 'X2', X2 write (LOUT, 2001) 'F1', F1, 'F2', F2 write (LOUT, 2001) 'D1', D1, 'D2', D2 ! end if ! ! COMPUTE FLOORS FOR RELATIVE ERRORS. ! if ( kprint >= 2) write (LOUT, 3001) X1, X2 FLOORF = max ( min ( ABS(F1),ABS(F2)), SMALL) ! ! CHECK REPRODUCTION OF ENDPOINT VALUES. ! FLOORD = max ( min ( ABS(D1),ABS(D2)), SMALL) XEV(1) = X1 ! ----------------------------------------------------------- XEV(2) = X2 call DCHFDV (X1, X2, F1, F2, D1, D2, 2, XEV, CHECKF, CHECKD, & ! ----------------------------------------------------------- NEXT, IERR) AEF = CHECKF(1)-F1 REF = RERR(AEF , F1, FLOORF) AEF2 = CHECKF(2)-F2 REF2 = RERR(AEF2, F2, FLOORF) AED = CHECKD(1)-D1 RED = RERR(AED , D1, FLOORD) AED2 = CHECKD(2)-D2 ! RED2 = RERR(AED2, D2, FLOORD) FAILOC = max ( ABS(REF),ABS(REF2),ABS(RED),ABS(RED2)) > TOL1 ! FAIL = FAIL .OR. FAILOC if ( kprint >= 3) THEN write (LOUT, 2002) NEXT, AEF, AEF2, AED, AED2 write (LOUT, 2003) REF, REF2, RED, RED2 ! end if ! ! DCHFEV SHOULD AGREE EXACTLY WITH DCHFDV. ! ------- ! -------------------------------------------------------------- if ( FAILOC .and. (KPRINT >= 2)) write (LOUT, 3002) ! -------------------------------------------------------------- call DCHFEV (X1, X2, F1, F2, D1, D2, 2, XEV, CHECK, NEXT, IERR) FAILOC = (CHECK(1) /= CHECKF(1)) .OR. (CHECK(2) /= CHECKF(2)) ! FAIL = FAIL .OR. FAILOC ! ! EVALUATE AT NPTS 'UNIFORMLY RANDOM' POINTS IN (X1,X2). ! THIS VERSION EXTENDS EVALUATION DOMAIN BY ADDING 4 SUBINTERVALS ! TO LEFT AND 6 TO RIGHT OF [X1,X2]. ! if ( FAILOC .and. (KPRINT >= 2)) write (LOUT, 3003) DX = (X2-X1)/(NPTS-10) DO 20 I = 1, NPTS XEV(I) = (X1 + (I-5)*DX) + DX*RAND(0.0E0) ! -------------------------------------------------------- 20 continue call DCHFDV (X1, X2, F1, F2, D1, D2, NPTS, XEV, FEV, DEV, & ! -------------------------------------------------------- NEXT, IERR) if ( IERR /= 0) THEN FAILOC = .TRUE. if ( kprint >= 2) write (LOUT, 4003) IERR ! ! CUMULATE LARGEST AND SMALLEST ERRORS FOR SUMMARY. ! else DO 30 I = 1, NPTS call DFDTRU (XEV(I), FTRUE, DTRUE) AEF = FEV(I) - FTRUE REF = RERR(AEF, FTRUE, FLOORF) AED = DEV(I) - DTRUE ! RED = RERR(AED, DTRUE, FLOORD) ! INITIALIZE. if ( I == 1) THEN AEFMIN = AEF AEFMAX = AEF AEDMIN = AED AEDMAX = AED REFMIN = REF REFMAX = REF REDMIN = RED REDMAX = RED XAFMIN = XEV(1) XAFMAX = XEV(1) XADMIN = XEV(1) XADMAX = XEV(1) XRFMIN = XEV(1) XRFMAX = XEV(1) XRDMIN = XEV(1) XRDMAX = XEV(1) ! SELECT. else if ( AEF < AEFMIN) THEN AEFMIN = AEF XAFMIN = XEV(I) else if ( AEF > AEFMAX) THEN AEFMAX = AEF XAFMAX = XEV(I) end if if ( AED < AEDMIN) THEN AEDMIN = AED XADMIN = XEV(I) else if ( AED > AEDMAX) THEN AEDMAX = AED XADMAX = XEV(I) end if if ( REF < REFMIN) THEN REFMIN = REF XRFMIN = XEV(I) else if ( REF > REFMAX) THEN REFMAX = REF XRFMAX = XEV(I) end if if ( RED < REDMIN) THEN REDMIN = RED XRDMIN = XEV(I) else if ( RED > REDMAX) THEN REDMAX = RED XRDMAX = XEV(I) end if end if ! 30 continue FERMAX = MAX (ABS(REFMAX), ABS(REFMIN)) ! DERMAX = MAX (ABS(REDMAX), ABS(REDMIN)) FAILNX = (NEXT(1) + NEXT(2)) /= 10 FAILOC = FAILNX .OR. (MAX(FERMAX, DERMAX) > TOL2) end if ! ! PRINT SUMMARY. ! FAIL = FAIL .OR. FAILOC if ( kprint >= 3) THEN ! write (LOUT, 2004) NPTS-10, NEXT write (LOUT, 2005) 'MIN', AEFMIN, REFMIN, AEDMIN, REDMIN write (LOUT, 2006) XAFMIN, XRFMIN, XADMIN, XRDMIN write (LOUT, 2005) 'MAX', AEFMAX, REFMAX, AEDMAX, REDMAX write (LOUT, 2006) XAFMAX, XRFMAX, XADMAX, XRDMAX ! end if if ( kprint >= 2) THEN if ( FAILOC ) then if ( FERMAX > TOL2) write (LOUT, 3006) 'F', FERMAX, TOL2 if ( DERMAX > TOL2) write (LOUT, 3006) 'D', DERMAX, TOL2 if ( FAILNX) write (LOUT, 4006) NEXT else write (LOUT, 5006) end if ! ! CHECK THAT DCHFEV AGREES WITH DCHFDV. ! ! ----------------------------------------------------------------- end if ! ----------------------------------------------------------------- call DCHFEV (X1, X2, F1, F2, D1, D2, NPTS, XEV, FEV2, NEXT2, IERR) if ( IERR /= 0) THEN FAILOC = .TRUE. if ( kprint >= 2) write (LOUT, 3007) IERR else AEFMAX = ABS(FEV2(1) - FEV(1)) XAFMAX = XEV(1) DO 40 I = 2, NPTS AEF = ABS(FEV2(I) - FEV(I)) if ( AEF > AEFMAX) THEN AEFMAX = AEF XAFMAX = XEV(I) end if 40 continue FAILNX = (NEXT2(1) /= NEXT(1)) .OR. (NEXT2(2) /= NEXT(2)) FAILOC = FAILNX .OR. (AEFMAX /= ZERO) if ( kprint >= 2) THEN if ( FAILOC) THEN write (LOUT, 3008) if ( AEFMAX /= ZERO) write (LOUT, 3009) AEFMAX, XAFMAX if ( FAILNX) write (LOUT, 4009) NEXT2, NEXT else write (LOUT, 5009) end if end if ! end if ! ! GO BACK FOR ANOTHER INTERVAL. ! FAIL = FAIL .OR. FAILOC ! 90 continue ! ! FORMATS. ! return 2000 FORMAT (/10X,'DCHFDV ACCURACY TEST') 2001 FORMAT (10X,A2,' =',1P,D18.10,5X,A2,' =',D18.10) 2002 FORMAT (/' ERRORS AT ENDPOINTS:',40X,'(NEXT =',2I3,')' & // 1P,4X,'F1:',D13.5,4X,'F2:',D13.5, & 4X,'D1:',D13.5,4X,'D2:',D13.5) 2003 FORMAT (1P,4(7X,D13.5)) 2004 FORMAT (/' ERRORS AT ',I5,' INTERIOR POINTS + 10 OUTSIDE:', & 15X,'(NEXT =',2I3,')' & //30X,'FUNCTION',17X,'DERIVATIVE' & /15X,2(11X,'ABS',9X,'REL') ) 2005 FORMAT (/5X,A3,'IMUM ERROR: ',1P,2D12.4,2X,2D12.4) 2006 FORMAT ( 5X,'LOCATED AT X = ',1P,2D12.4,2X,2D12.4) 3000 FORMAT (//10X,'DEVCHK RESULTS'/10X,'--------------') 3001 FORMAT (/10X,'INTERVAL = (',1P,D12.5,',',D12.5,' ):' ) 3002 FORMAT (/' ***** DCHFDV FAILED TO REPRODUCE ENDPOINT VALUES.') 3003 FORMAT (/' ***** DCHFEV DOES NOT AGREE WITH DCHFDV AT ENDPOINTS.') 3006 FORMAT (/' ***** MAXIMUM RELATIVE ERROR IN ',A1,' =',1P,D12.5,',' & / 17X,'EXCEEDS TOLERANCE =',D12.5) 3007 FORMAT (/' ***** ERROR ***** DCHFEV RETURNED IERR =',I5) 3008 FORMAT (/' ***** DCHFEV DID NOT AGREE WITH DCHFDV:') 3009 FORMAT (7X,'MAXIMUM DIFFERENCE ',1P,D12.5, & '; OCCURRED AT X =',D12.5) 4003 FORMAT (/' ***** ERROR ***** DCHFDV RETURNED IERR =',I5) 4006 FORMAT (/' ***** REPORTED NEXT =',2I5,' RATHER THAN 4 6') 4009 FORMAT (7X,'REPORTED NEXT =',2I3,' RATHER THAN ',2I3) 5006 FORMAT (/' DCHFDV RESULTS OK.') ! -------- LAST LINE OF DEVCHK FOLLOWS ----------------------------- 5009 FORMAT (/' DCHFEV AGREES WITH DCHFDV.') end !! DEVERK !***SUBSIDIARY !***PURPOSE Test error returns from DPCHIP evaluators for DPCHQ1. !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (EVERCK-S, DEVERK-D) !***KEYWORDS PCHIP EVALUATOR QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! --------- CODE TO TEST ERROR RETURNS FROM DPCHIP EVALUATORS. --------- ! ! ! FORTRAN LIBRARY ROUTINES USED: (WRITE). ! SLATEC LIBRARY ROUTINES USED: DCHFDV, DCHFEV, DPCHFD, DPCHFE, ! XERDMP, XGETF, XSETF. ! OTHER ROUTINES USED: COMP. ! !***ROUTINES CALLED COMP, DCHFDV, DCHFEV, DPCHFD, DPCHFE, XERDMP, ! XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 820715 CONVERTED TO QUICK CHECK FOR SLATEC LIBRARY. ! 890207 ADDED CALLS TO ERROR HANDLER. ! 890316 Added call to XERDMP if kprint > 2 (FNF). ! 890706 Cosmetic changes to prologue. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891009 Removed unreferenced statement label. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900309 Added COMP to list of routines called. (FNF) ! 900315 Revised prologue and improved some output formats. (FNF) ! 900316 Deleted INCFD tests because some compilers object to them, ! and made additional minor cosmetic changes. (FNF) ! 900322 Made miscellaneous cosmetic changes. (FNF) ! 910708 Minor modifications in use of KPRINT. (WRB) ! 930504 Removed parens from constants in write statements. (FNF) !***END PROLOGUE DEVERK ! ! Declare arguments. ! subroutine DEVERK (LOUT, KPRINT, FAIL) integer LOUT, KPRINT ! ! DECLARATIONS. ! LOGICAL FAIL integer I, IERR, KONTRL, N, NERR, NEXT(2) double precision D(10), DUM, F(10), TEMP, X(10) ! ! INITIALIZE. ! LOGICAL COMP, SKIP !***FIRST EXECUTABLE STATEMENT DEVERK PARAMETER (N = 10) ! NERR = 0 call XGETF (KONTRL) if ( kprint <= 2 ) then call XSETF (0) else call XSETF (1) ! end if if ( kprint >= 3) write (LOUT, 2000) ! ! FIRST, TEST DCHFEV AND DCHFDV. ! if ( kprint >= 2) write (LOUT, 5000) if ( kprint >= 3) write (LOUT, 5001) -1 call DCHFEV (0.D0, 1.D0, 3.D0, 7.D0, 3.D0, 6.D0, 0, DUM, DUM, & NEXT, IERR) ! if ( .NOT. COMP (IERR, -1, LOUT, KPRINT) ) NERR = NERR + 1 if ( kprint >= 3) write (LOUT, 5001) -2 call DCHFEV (1.D0, 1.D0, 3.D0, 7.D0, 3.D0, 6.D0, 1, DUM, DUM, & NEXT, IERR) ! if ( .NOT. COMP (IERR, -2, LOUT, KPRINT) ) NERR = NERR + 1 if ( kprint >= 3) write (LOUT, 5001) -1 call DCHFDV (0.D0, 1.D0, 3.D0, 7.D0, 3.D0, 6.D0, 0, DUM, DUM, & DUM, NEXT, IERR) ! if ( .NOT. COMP (IERR, -1, LOUT, KPRINT) ) NERR = NERR + 1 if ( kprint >= 3) write (LOUT, 5001) -2 call DCHFDV (1.D0, 1.D0, 3.D0, 7.D0, 3.D0, 6.D0, 1, DUM, DUM, & DUM, NEXT, IERR) ! ! SET UP PCH DEFINITION. ! if ( .NOT. COMP (IERR, -2, LOUT, KPRINT) ) NERR = NERR + 1 DO 10 I = 1, N X(I) = I F(I) = I + 2 D(I) = 1.D0 ! ! SWAP POINTS 4 AND 7, SO X-ARRAY IS OUT OF ORDER. ! 10 continue TEMP = X(4) X(4) = X(7) ! ! NOW, TEST DPCHFE AND DPCHFD. ! X(7) = TEMP if ( kprint >= 3) write (LOUT, 5001) -1 SKIP = .FALSE. call DPCHFE (1, X, F, D, 1, SKIP, 0, DUM, DUM, IERR) ! if ( .NOT. COMP (IERR, -1, LOUT, KPRINT) ) NERR = NERR + 1 if ( kprint >= 3) write (LOUT, 5001) -3 SKIP = .FALSE. call DPCHFE (N, X, F, D, 1, SKIP, 0, DUM, DUM, IERR) ! if ( .NOT. COMP (IERR, -3, LOUT, KPRINT) ) NERR = NERR + 1 if ( kprint >= 3) write (LOUT, 5001) -4 SKIP = .TRUE. call DPCHFE (N, X, F, D, 1, SKIP, 0, DUM, DUM, IERR) ! if ( .NOT. COMP (IERR, -4, LOUT, KPRINT) ) NERR = NERR + 1 if ( kprint >= 3) write (LOUT, 5001) -1 SKIP = .FALSE. call DPCHFD (1, X, F, D, 1, SKIP, 0, DUM, DUM, DUM, IERR) ! if ( .NOT. COMP (IERR, -1, LOUT, KPRINT) ) NERR = NERR + 1 if ( kprint >= 3) write (LOUT, 5001) -3 SKIP = .FALSE. call DPCHFD (N, X, F, D, 1, SKIP, 0, DUM, DUM, DUM, IERR) ! if ( .NOT. COMP (IERR, -3, LOUT, KPRINT) ) NERR = NERR + 1 if ( kprint >= 3) write (LOUT, 5001) -4 SKIP = .TRUE. call DPCHFD (N, X, F, D, 1, SKIP, 0, DUM, DUM, DUM, IERR) ! ! SUMMARIZE RESULTS. ! if ( .NOT. COMP (IERR, -4, LOUT, KPRINT) ) NERR = NERR + 1 if ( kprint > 2) call XERDMP if ( NERR == 0) THEN FAIL = .FALSE. if ( kprint >= 2) write (LOUT, 5002) else FAIL = .TRUE. if ( kprint >= 2) write (LOUT, 5003) NERR ! ! TERMINATE. ! end if call XSETF (KONTRL) ! ! FORMATS. ! return 2000 FORMAT ('1'//10X,'TEST ERROR RETURNS') 5000 FORMAT (//10X,'DEVERK RESULTS'/10X,'--------------') 5001 FORMAT (/' THIS call SHOULD RETURN IERR =',I3) 5002 FORMAT (/' ALL ERROR RETURNS OK.') 5003 FORMAT (//' ***** TROUBLE IN DEVERK *****' & ! -------- LAST LINE OF DEVERK FOLLOWS ----------------------------- //5X,I5,' TESTS FAILED TO GIVE EXPECTED RESULTS.') end subroutine DEVPCK (LOUT, KPRINT, X, Y, F, FX, FY, XE, YE, FE, DE, & !! DEVPCK !***SUBSIDIARY !***PURPOSE Test usage of increment argument in DPCHFD and DPCHFE for ! DPCHQ1. !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (EVPCCK-S, DEVPCK-D) !***KEYWORDS PCHIP EVALUATOR QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! ---- CODE TO TEST USAGE OF INCREMENT ARGUMENT IN DPCHFD AND DPCHFE --- ! ! EVALUATES A BICUBIC FUNCTION AND ITS FIRST PARTIAL DERIVATIVES ! ON A 4X6 MESH CONTAINED IN A 10X10 ARRAY. ! ! INTERPOLATION OF THESE DATA ALONG MESH LINES IN EITHER DIMENSION ! SHOULD AGREE WITH CORRECT FUNCTION WITHIN ROUNDOFF ERROR. ! ! ARRAYS ARE ARGUMENTS ONLY TO ALLOW SHARING STORAGE WITH OTHER ! TEST ROUTINES. ! ! NOTE: RUN WITH KPRINT=4 FOR FULL GORY DETAILS (10 PAGES WORTH). ! ! ! FORTRAN INTRINSICS USED: ABS. ! FORTRAN LIBRARY ROUTINES USED: (WRITE). ! SLATEC LIBRARY ROUTINES USED: DPCHFD, DPCHFE, d1mach. ! !***ROUTINES CALLED d1mach, DPCHFD, DPCHFE !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 820714 CONVERTED TO QUICK CHECK FOR SLATEC LIBRARY. ! 820715 1. CORRECTED SOME FORMATS. ! 2. ADDED call TO d1mach TO SET MACHEP. ! 890406 1. Modified to make sure final elements of X and XE ! agree, to avoid possible failure due to roundoff ! error. ! 2. Added printout of TOL in case of failure. ! 3. Removed unnecessary IMPLICIT declaration. ! 4. Corrected a few S.P. constants to D.P. ! 5. Minor cosmetic changes. ! 890706 Cosmetic changes to prologue. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891004 Cosmetic changes to prologue. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 Revised prologue and improved some output formats. (FNF) ! 900316 Additional minor cosmetic changes. (FNF) ! 900321 Made miscellaneous cosmetic changes. (FNF) ! 901130 Made many changes to output: (FNF) ! 1. Reduced amount of output for KPRINT=3. (Now need to ! use KPRINT=4 for full output.) ! 2. Added 1P's to formats and revised some to reduce maximum ! line length. ! 910708 Minor modifications in use of KPRINT. (WRB) ! 930317 Improved output formats. (FNF) !***END PROLOGUE DEVPCK ! ! Declare arguments. ! FE2, FAIL) integer LOUT, KPRINT LOGICAL FAIL double precision & X(10), Y(10), F(10,10), FX(10,10), FY(10,10), & ! ! DECLARATIONS. ! XE(51), YE(51), FE(51), DE(51), FE2(51) integer I, IER2, IERR, INC, J, K, NE, NERR, NMAX, NX, NY LOGICAL FAILD, FAILE, FAILOC, SKIP double precision & DERMAX, DERR, DTRUE, DX, FDIFF, FDIFMX, FERMAX, FERR, & FTRUE, MACHEP, TOL, PDERMX, PDIFMX, PFERMX, ZERO ! ! DEFINE TEST FUNCTION AND DERIVATIVES. ! double precision d1mach double precision AX, AY, FCN, DFDX, DFDY FCN (AX,AY) = AX*(AY*AY)*(AX*AX + 1.D0) DFDX(AX,AY) = (AY*AY)*(3.D0*AX*AX + 1.D0) ! DFDY(AX,AY) = 2.D0*AX*AY*(AX*AX + 1.D0) DATA NMAX /10/, NX /4/, NY /6/ DATA NE /51/ ! ! INITIALIZE. ! !***FIRST EXECUTABLE STATEMENT DEVPCK DATA ZERO /0.D0/ ! Following tolerance is looser than S.P. version to avoid ! spurious failures on some systems. MACHEP = d1mach(4) ! TOL = 25.D0*MACHEP ! ! SET UP 4-BY-6 MESH IN A 10-BY-10 ARRAY: ! X = 0.25(0.25)1. ; ! Y = -0.75(0.5 )1.75 . ! FAIL = .FALSE. DO 1 I = 1, NX-1 X(I) = 0.25D0*I 1 continue X(NX) = 1.D0 DO 5 J = 1, NY Y(J) = 0.5D0*J - 1.25D0 DO 4 I = 1, NX F(I,J) = FCN (X(I), Y(J)) FX(I,J) = DFDX(X(I), Y(J)) FY(I,J) = DFDY(X(I), Y(J)) 4 continue ! ! SET UP EVALUATION POINTS: ! XE = 0.(0.02)1. ; ! YE = -2.(0.08)2. . ! 5 continue DX = 1.D0/(NE-1) DO 8 K = 1, NE-1 XE(K) = DX*(K-1) YE(K) = 4.D0*XE(K) - 2.D0 8 continue XE(NE) = 1.D0 ! YE(NE) = 2.D0 if ( kprint >= 3) write (LOUT, 1000) ! ! EVALUATE ON HORIZONTAL MESH LINES (Y FIXED, X RUNNING) .............. ! if ( kprint >= 2) write (LOUT, 1001) NERR = 0 INC = 1 SKIP = .FALSE. ! -------------------------------------------------------------- DO 20 J = 1, NY call DPCHFD (NX, X, F(1,J), FX(1,J), INC, SKIP, NE, XE, FE, DE, & ! -------------------------------------------------------------- IERR) if ( kprint >= 3) & write (LOUT, 2000) INC, 'J', J, 'Y', Y(J), IERR if ( IERR < 0) GO TO 15 ! ! DPCHFE SHOULD AGREE EXACTLY WITH DPCHFD. ! ! ----------------------------------------------------------- if ( kprint > 3) write (LOUT, 2001) 'X' call DPCHFE (NX, X, F(1,J), FX(1,J), INC, SKIP, NE, XE, FE2, & ! ----------------------------------------------------------- ! IER2) DO 10 K = 1, NE FTRUE = FCN(XE(K), Y(J)) FERR = FE(K) - FTRUE DTRUE = DFDX(XE(K), Y(J)) DERR = DE(K) - DTRUE if ( kprint > 3) & write (LOUT, 2002) XE(K), FTRUE, FE(K), FERR, & DTRUE, DE(K), DERR ! INITIALIZE. if ( K == 1) THEN FERMAX = ABS(FERR) PFERMX = XE(1) DERMAX = ABS(DERR) PDERMX = XE(1) FDIFMX = ABS(FE2(1) - FE(1)) PDIFMX = XE(1) ! SELECT. else FERR = ABS(FERR) if ( FERR > FERMAX) THEN FERMAX = FERR PFERMX = XE(K) end if DERR = ABS(DERR) if ( DERR > DERMAX) THEN DERMAX = DERR PDERMX = XE(K) end if FDIFF = ABS(FE2(K) - FE(K)) if ( FDIFF > FDIFMX) THEN FDIFMX = FDIFF PDIFMX = XE(K) end if end if ! 10 continue FAILD = (FERMAX > TOL) .OR. (DERMAX > TOL) FAILE = FDIFMX /= ZERO ! FAILOC = FAILD .OR. FAILE .OR. (IERR /= 13) .OR. (IER2 /= IERR) if ( FAILOC .and. (KPRINT >= 2)) & ! write (LOUT, 2003) 'J', J, 'Y', Y(J) if ( (KPRINT >= 3) .OR. (FAILD .and. (KPRINT == 2)) ) & write (LOUT, 2004) FERMAX, PFERMX, DERMAX, PDERMX ! if ( FAILD .and. (KPRINT >= 2)) write (LOUT, 2014) TOL if ( (KPRINT >= 3) .OR. (FAILE .and. (KPRINT == 2)) ) & ! write (LOUT, 2005) FDIFMX, PDIFMX if ( (IERR /= 13) .and. (KPRINT >= 2)) & ! write (LOUT, 2006) 'D', IERR, 13 if ( (IER2 /= IERR) .and. (KPRINT >= 2)) & write (LOUT, 2006) 'E', IER2, IERR ! GO TO 19 15 continue FAILOC = .TRUE. ! if ( kprint >= 2) write (LOUT, 3000) IERR 19 continue if ( FAILOC) NERR = NERR + 1 FAIL = FAIL .OR. FAILOC ! 20 continue if ( kprint >= 2) THEN if ( NERR > 0) THEN write (LOUT, 3001) NERR, 'J' else write (LOUT, 4000) 'J' end if ! ! EVALUATE ON VERTICAL MESH LINES (X FIXED, Y RUNNING) ................ ! end if NERR = 0 INC = NMAX SKIP = .FALSE. ! -------------------------------------------------------------- DO 40 I = 1, NX call DPCHFD (NY, Y, F(I,1), FY(I,1), INC, SKIP, NE, YE, FE, DE, & ! -------------------------------------------------------------- IERR) if ( kprint >= 3) & write (LOUT, 2000) INC, 'I', I, 'X', X(I), IERR if ( IERR < 0) GO TO 35 ! ! DPCHFE SHOULD AGREE EXACTLY WITH DPCHFD. ! ! ----------------------------------------------------------- if ( kprint > 3) write (LOUT, 2001) 'Y' call DPCHFE (NY, Y, F(I,1), FY(I,1), INC, SKIP, NE, YE, FE2, & ! ----------------------------------------------------------- ! IER2) DO 30 K = 1, NE FTRUE = FCN(X(I), YE(K)) FERR = FE(K) - FTRUE DTRUE = DFDY(X(I), YE(K)) DERR = DE(K) - DTRUE if ( kprint > 3) & write (LOUT, 2002) YE(K), FTRUE, FE(K), FERR, & DTRUE, DE(K), DERR ! INITIALIZE. if ( K == 1) THEN FERMAX = ABS(FERR) PFERMX = YE(1) DERMAX = ABS(DERR) PDERMX = YE(1) FDIFMX = ABS(FE2(1) - FE(1)) PDIFMX = YE(1) ! SELECT. else FERR = ABS(FERR) if ( FERR > FERMAX) THEN FERMAX = FERR PFERMX = YE(K) end if DERR = ABS(DERR) if ( DERR > DERMAX) THEN DERMAX = DERR PDERMX = YE(K) end if FDIFF = ABS(FE2(K) - FE(K)) if ( FDIFF > FDIFMX) THEN FDIFMX = FDIFF PDIFMX = YE(K) end if end if 30 continue FAILD = (FERMAX > TOL) .OR. (DERMAX > TOL) FAILE = FDIFMX /= ZERO FAILOC = FAILD .OR. FAILE .OR. (IERR /= 20) .OR. (IER2 /= IERR) if ( FAILOC .and. (KPRINT >= 2)) & write (LOUT, 2003) 'I', I, 'X', X(I) if ( (KPRINT >= 3) .OR. (FAILD .and. (KPRINT == 2)) ) & write (LOUT, 2004) FERMAX, PFERMX, DERMAX, PDERMX if ( FAILD .and. (KPRINT >= 2)) write (LOUT, 2014) TOL if ( (KPRINT >= 3) .OR. (FAILE .and. (KPRINT == 2)) ) & write (LOUT, 2005) FDIFMX, PDIFMX if ( (IERR /= 20) .and. (KPRINT >= 2)) & write (LOUT, 2006) 'D', IERR, 20 if ( (IER2 /= IERR) .and. (KPRINT >= 2)) & write (LOUT, 2006) 'E', IER2, IERR GO TO 39 35 continue FAILOC = .TRUE. if ( kprint >= 2) write (LOUT, 3000) IERR 39 continue if ( FAILOC) NERR = NERR + 1 FAIL = FAIL .OR. FAILOC 40 continue if ( kprint >= 2) THEN if ( NERR > 0) THEN write (LOUT, 3001) NERR, 'I' else write (LOUT, 4000) 'I' end if ! ! TERMINATE. ! end if ! ! FORMATS. ! return 1000 FORMAT ('1'//10X,'TEST DPCHFE AND DPCHFD') 1001 FORMAT (//10X,'DEVPCK RESULTS'/10X,'--------------') 2000 FORMAT (//20X,'DPCHFD INCREMENT TEST -- INCFD = ',I2 & /15X,'ON ',A1,'-LINE ',I2,', ',A1,' =',F8.4, & ' -- IERR =',I3) 2001 FORMAT ( /3X,A1,'E',10X,'F',8X,'FE',9X,'DIFF', & 13X,'D',8X,'DE',9X,'DIFF') 2002 FORMAT (F7.2,2(2X,2F10.5,1P,D15.5,0P)) 2003 FORMAT (/' ***** DPCHFD AND/OR DPCHFE FAILED ON ',A1,'-LINE ',I1, & ', ',A1,' =',F8.4) 2004 FORMAT (/19X,' MAXIMUM ERROR IN FUNCTION =',1P, & 1P,D13.5,0P,' (AT',F6.2,'),' & /33X, 'IN DERIVATIVE =',1P,D13.5,0P,' (AT',F6.2,').' ) 2005 FORMAT ( ' MAXIMUM DIFFERENCE BETWEEN DPCHFE AND DPCHFD =', & 1P,D13.5,0P,' (AT',F6.2,').' ) 2006 FORMAT (/' DPCHF',A1,' RETURNED IERR = ',I2,' INSTEAD OF ',I2) 2014 FORMAT (' *** BOTH SHOULD BE <= TOL =',1P,D12.5,' ***') 3000 FORMAT (//' ***** ERROR ***** DPCHFD RETURNED IERR =',I5//) 3001 FORMAT (//' ***** ERROR ***** DPCHFD AND/OR DPCHFE FAILED ON',I2, & 1X, A1,'-LINES.'//) ! -------- LAST LINE OF DEVPCK FOLLOWS ----------------------------- 4000 FORMAT (/' DPCHFD AND DPCHFE OK ON ',A1,'-LINES.') end !! DF0C !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF0C double precision FUNCTION DF0C (X) !***FIRST EXECUTABLE STATEMENT DF0C double precision X DF0C = 1.D0/(X*X+1.D-4) return end !! DF0F !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF0F double precision FUNCTION DF0F (X) !***FIRST EXECUTABLE STATEMENT DF0F double precision X DF0F = 0.0D+00 if ( X /= 0.0D+00) DF0F = SIN(0.5D+02*X)/(X*SQRT(X)) return end !! DF0O !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF0O double precision FUNCTION DF0O (X) !***FIRST EXECUTABLE STATEMENT DF0O double precision X DF0O = (0.2D+01*SIN(X))**14 return end !! DF0S !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF0S double precision FUNCTION DF0S (X) !***FIRST EXECUTABLE STATEMENT DF0S double precision X DF0S = 0.0D+00 if ( X /= 0.0D+00) DF0S = 0.1D+01/SQRT(X) return end !! DF0WS !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF0WS double precision FUNCTION DF0WS (X) !***FIRST EXECUTABLE STATEMENT DF0WS double precision X DF0WS = SIN(0.1D+02*X) return end !! DF1C !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF1C double precision FUNCTION DF1C (X) !***FIRST EXECUTABLE STATEMENT DF1C double precision X DF1C = 0.0D+00 if ( X /= 0.33D+00) DF1C = (X-0.5D+00)*ABS(X-0.33D+00)**(-0.9D+00) return end !! DF1F !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF1F double precision FUNCTION DF1F (X) !***FIRST EXECUTABLE STATEMENT DF1F double precision X,X1,Y X1 = X+0.1D+01 DF1F = 0.5D+01/X1/X1 Y = 0.5D+01/X1 if ( Y > 3.1415926535897932D0) DF1F = 0.0D0 return end !! DF1G !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF1G double precision FUNCTION DF1G (X) double precision PI,X !***FIRST EXECUTABLE STATEMENT DF1G DATA PI /3.1415926535897932D0/ DF1G = 2.0D0/(2.0D0+SIN(10.0D0*PI*X)) return end !! DF1N !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF1N double precision FUNCTION DF1N (X) !***FIRST EXECUTABLE STATEMENT DF1N double precision X DF1N=1.0D0/(X**4+X**2+1.0D0) return end !! DF1O !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF1O double precision FUNCTION DF1O (X) !***FIRST EXECUTABLE STATEMENT DF1O double precision X DF1O = 0.1D+01 if ( X > 0.31415926535897932D+01) DF1O = 0.0D+00 return end !! DF1P !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF1P double precision FUNCTION DF1P (X) !***FIRST EXECUTABLE STATEMENT DF1P ! P1 = 1/7, P2 = 2/3 double precision ALFA1,ALFA2,P1,P2,X,D1,D2 DATA P1/0.1428571428571428D+00/ DATA P2/0.6666666666666667D+00/ ALFA1 = -0.25D0 ALFA2 = -0.5D0 D1=ABS(X-P1) D2=ABS(X-P2) DF1P = 0.0D+00 if ( D1 /= 0.0D+00 .and. D2 /= 0.0D+00) DF1P = D1**ALFA1+D2**ALFA2 return end !! DF1S !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF1S double precision FUNCTION DF1S (X) !***FIRST EXECUTABLE STATEMENT DF1S double precision X DF1S = 0.2D+01/(0.2D+01+SIN(0.314159D+02*X)) return end !! DF1WS !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF1WS double precision FUNCTION DF1WS (X) !***FIRST EXECUTABLE STATEMENT DF1WS double precision X DF1WS = 0.00D+00 if ( X-0.33D+00 /= 0.00D+00) DF1WS=ABS(X-0.33D+00)**(-0.999D+00) return end !! DF2G !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF2G double precision FUNCTION DF2G (X) !***FIRST EXECUTABLE STATEMENT DF2G double precision X DF2G = X*SIN(0.3D+02*X)*COS(0.5D+02*X) return end !! DF2N !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF2N double precision FUNCTION DF2N (X) !***FIRST EXECUTABLE STATEMENT DF2N double precision X DF2N=X**(-0.9D+00) return end !! DF2O !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF2O double precision FUNCTION DF2O (X) !***FIRST EXECUTABLE STATEMENT DF2O double precision X DF2O = 0.0D+00 if ( X /= 0.0D+00) DF2O = 0.1D+01/(X*X*SQRT(X)) return end !! DF2P !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF2P double precision FUNCTION DF2P (X) !***FIRST EXECUTABLE STATEMENT DF2P double precision X DF2P = SIN(0.314159D+03*X)/(0.314159D+01*X) return end !! DF2S !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF2S double precision FUNCTION DF2S (X) !***FIRST EXECUTABLE STATEMENT DF2S double precision X DF2S = 0.1D+03 if ( X /= 0.0D+00) DF2S = SIN(0.314159D+03*X)/(0.314159D+01*X) return end !! DF3G !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF3G double precision FUNCTION DF3G (X) !***FIRST EXECUTABLE STATEMENT DF3G double precision X DF3G=ABS(X-0.33D+00)**(-.90D+00) return end !! DF3P !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF3P double precision FUNCTION DF3P (X) !***FIRST EXECUTABLE STATEMENT DF3P double precision X DF3P = 0.1D+01 if ( X > 0.31415926535897932D+01) DF3P = 0.0D+00 return end !! DF3S !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF3S double precision FUNCTION DF3S (X) !***FIRST EXECUTABLE STATEMENT DF3S double precision X DF3S = 0.1D+01 if ( X > 0.31415926535897932D+01) DF3S = 0.0D+00 return end !! DF4P !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF4P double precision FUNCTION DF4P (X) !***FIRST EXECUTABLE STATEMENT DF4P double precision X DF4P = 0.0D+00 if ( X > 0.0D+00) DF4P = 0.1D+01/(X*SQRT(X)) return end !! DF4S !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF4S double precision FUNCTION DF4S (X) !***FIRST EXECUTABLE STATEMENT DF4S double precision X DF4S = 0.00D+00 if ( X-0.33D+00 /= 0.00D+00) DF4S=ABS(X-0.33D+00)**(-0.999D+00) return end !! DF5S !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DF5S double precision FUNCTION DF5S (X) !***FIRST EXECUTABLE STATEMENT DF5S double precision X DF5S = 0.0D+00 if ( X /= 0.0D+00) DF5S = 1.0D+00/(X*SQRT(X)) return end !! DFB !***PURPOSE Subsidiary to DBSPCK. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (FB-S, DFB-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 930214 Added TYPE statement. (WRB) !***END PROLOGUE DFB double precision FUNCTION DFB (X) !***FIRST EXECUTABLE STATEMENT DFB double precision X DFB = 1.0D0 return end !! DFCN1 !***PURPOSE Subsidiary to DNLS1Q. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (FCN1-S, DFCN1-D) !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine which evaluates the function for test program ! used in quick check of DNLS1E. ! ! Numerical approximation of Jacobian is used. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 930214 TYPE and declarations sections added. (WRB) !***END PROLOGUE DFCN1 ! .. Scalar Arguments .. subroutine DFCN1 (IFLAG, M, N, X, FVEC, FJAC, LDFJAC) double precision FJAC ! .. Array Arguments .. integer IFLAG, LDFJAC, M, N ! .. Local Scalars .. double precision FVEC(*), X(*) double precision TEMP, TWO ! .. Intrinsic Functions .. integer I ! .. Data statements .. INTRINSIC EXP !***FIRST EXECUTABLE STATEMENT DFCN1 DATA TWO /2.0D0/ if ( IFLAG /= 1) RETURN DO 10 I = 1,M TEMP = I FVEC(I) = TWO + TWO*TEMP - EXP(TEMP*X(1)) - EXP(TEMP*X(2)) 10 continue return end !! DFCN2 !***PURPOSE Subsidiary to DNLS1Q. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (FCN2-S, DFCN2-D) !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine to evaluate function and full Jacobian for test ! problem in quick check of DNLS1E. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 930214 TYPE and declarations sections added and code polished. ! (WRB) !***END PROLOGUE DFCN2 ! .. Scalar Arguments .. subroutine DFCN2 (IFLAG, M, N, X, FVEC, FJAC, LDFJAC) ! .. Array Arguments .. integer IFLAG, LDFJAC, M, N ! .. Local Scalars .. double precision FJAC(LDFJAC,*), FVEC(*), X(*) double precision TEMP, TWO ! .. Intrinsic Functions .. integer I ! .. Data statements .. INTRINSIC EXP !***FIRST EXECUTABLE STATEMENT DFCN2 DATA TWO /2.0D0/ ! ! Should we evaluate function or Jacobian? ! if ( IFLAG == 0) RETURN ! ! Evaluate functions. ! if ( IFLAG == 1 ) then DO 10 I = 1,M TEMP = I FVEC(I) = TWO + TWO*TEMP - EXP(TEMP*X(1)) - EXP(TEMP*X(2)) 10 continue ! ! Evaluate Jacobian. ! else if ( IFLAG /= 2) RETURN DO 20 I = 1,M TEMP = I FJAC(I,1) = -TEMP*EXP(TEMP*X(1)) FJAC(I,2) = -TEMP*EXP(TEMP*X(2)) 20 continue end if return end !! DFCN3 !***PURPOSE Subsidiary to DNLS1Q. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (FCN3-S, DFCN3-D) !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine to evaluate the Jacobian, one row at a time, for ! test problem used in quick check of DNLS1E. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 930214 TYPE and declarations sections added and code polished. ! (WRB) !***END PROLOGUE DFCN3 ! .. Scalar Arguments .. subroutine DFCN3 (IFLAG, M, N, X, FVEC, FJROW, NROW) ! .. Array Arguments .. integer IFLAG, M, N, NROW ! .. Local Scalars .. double precision FJROW(*), FVEC(*), X(*) double precision TEMP, TWO ! .. Intrinsic Functions .. integer I ! .. Data statements .. INTRINSIC EXP !***FIRST EXECUTABLE STATEMENT DFCN3 DATA TWO /2.0D0/ ! ! Should we evaluate functions or Jacobian? ! if ( IFLAG == 0) RETURN ! ! Evaluate functions. ! if ( IFLAG == 1 ) then DO I = 1,M TEMP = I FVEC(I) = TWO + TWO*TEMP - EXP(TEMP*X(1)) - EXP(TEMP*X(2)) end do ! ! Evaluate one row of Jacobian. ! else if ( IFLAG /= 3) RETURN TEMP = NROW FJROW(1) = -TEMP*EXP(TEMP*X(1)) FJROW(2) = -TEMP*EXP(TEMP*X(2)) end if return end !! DFCQX !***PURPOSE Quick check for DFC. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (FCQX-S, DFCQX-D) !***KEYWORDS QUICK CHECK !***AUTHOR Hanson, R. J., (SNLA) !***DESCRIPTION ! ! Quick check subprogram for the subroutine DFC. ! ! Fit discrete data by an S-shaped curve. Evaluate the fitted curve, ! its first two derivatives, and probable error curve. ! ! Use subprogram DFC to obtain the constrained cubic B-spline ! representation of the curve. ! ! The values of the coefficients of the B-spline as computed by DFC ! and the values of the fitted curve as computed by DBVALU in the ! de Boor package are tested for accuracy with the expected values. ! See the example program in the report sand78-1291, pp. 22-27. ! ! The dimensions in the following arrays are as small as possible for ! the problem being solved. ! !***ROUTINES CALLED d1mach, DBVALU, DCOPY, DCV, DFC, DMOUT, DVOUT, ! IVOUT !***REVISION HISTORY (YYMMDD) ! 780801 DATE WRITTEN ! 890718 Changed references from DBVLUE to DBVALU. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891004 Changed computation of XVAL. (WRB) ! 891004 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if, modified tolerances ! to use d1mach(4) rather than d1mach(3) and cleaned up ! FORMATs. (RWC) ! 930214 Declarations sections added, code revised to test error ! returns for all values of kprint and code polished. (WRB) !***END PROLOGUE DFCQX ! .. Scalar Arguments .. subroutine DFCQX (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN double precision DIFF, ONE, T, TOL, XVAL, ZERO integer KONTRL, I, IDIGIT, II, J, L, LAST, MODE, N, NBKPT, & NCONST, NDATA, NDEG, NERR, NORD, NVAL ! .. Local Arrays .. LOGICAL FATAL double precision BKPT(13), CHECK(51), COEFCK(9), COEFF(9), & SDDATA(9), V(51,5), W(529), WORK(12), XCONST(11), & XDATA(9), YCONST(11), YDATA(9) ! .. External Functions .. integer IW(30), NDERIV(11) double precision d1mach, DBVALU, DCV integer NUMXER ! .. External Subroutines .. EXTERNAL DBVALU, DCV, NUMXER, d1mach ! .. Intrinsic Functions .. EXTERNAL DCOPY, DFC, DMOUT, DVOUT, IVOUT, XGETF, XSETF ! .. Data statements .. ! INTRINSIC ABS, DBLE, SQRT DATA XDATA(1),XDATA(2),XDATA(3),XDATA(4),XDATA(5),XDATA(6), & XDATA(7),XDATA(8),XDATA(9) & /0.15D0,0.27D0,0.33D0,0.40D0,0.43D0,0.47D0, & 0.53D0,0.58D0,0.63D0/ DATA YDATA(1),YDATA(2),YDATA(3),YDATA(4),YDATA(5),YDATA(6), & YDATA(7),YDATA(8),YDATA(9) & /0.025D0,0.05D0,0.13D0,0.27D0,0.37D0,0.47D0, & 0.64D0,0.77D0,0.87D0/ DATA SDDATA(1)/0.015D0/, NDATA/9/, NORD/4/, NBKPT/13/, LAST/10/ DATA BKPT(1),BKPT(2),BKPT(3),BKPT(4),BKPT(5),BKPT(6),BKPT(7), & BKPT(8),BKPT(9),BKPT(10),BKPT(11),BKPT(12),BKPT(13) & /-0.6D0,-0.4D0,-0.2D0,0.0D0,0.2D0,0.4D0,0.6D0, & ! ! Store the data to be used to check the accuracy of the computed ! results. See SAND78-1291, p.26. ! 0.8D0,0.9D0,1.0D0,1.1D0,1.2D0,1.3D0/ DATA COEFCK(1),COEFCK(2),COEFCK(3),COEFCK(4),COEFCK(5),COEFCK(6), & COEFCK(7),COEFCK(8),COEFCK(9) & /1.186380846D-13,-2.826166426D-14,-4.333929094D-15, & 1.722113311D-01, 9.421965984D-01, 9.684708719D-01, & 9.894902905D-01, 1.005254855D+00, 9.894902905D-01/ DATA CHECK(1),CHECK(2),CHECK(3),CHECK(4),CHECK(5),CHECK(6), & CHECK(7),CHECK(8),CHECK(9) & /2.095830752D-16, 2.870188850D-05, 2.296151081D-04, & 7.749509897D-04, 1.836920865D-03, 3.587736064D-03, & 6.199607918D-03, 9.844747759D-03, 1.469536692D-02/ DATA CHECK(10),CHECK(11),CHECK(12),CHECK(13),CHECK(14),CHECK(15), & CHECK(16),CHECK(17),CHECK(18) & /2.092367672D-02, 2.870188851D-02, 3.824443882D-02, & 4.993466504D-02, 6.419812979D-02, 8.146039566D-02, & 1.021470253D-01, 1.266835812D-01, 1.554956261D-01/ DATA CHECK(19),CHECK(20),CHECK(21),CHECK(22),CHECK(23),CHECK(24), & CHECK(25),CHECK(26),CHECK(27) & /1.890087225D-01, 2.276484331D-01, 2.718403204D-01, & 3.217163150D-01, 3.762338189D-01, 4.340566020D-01, & 4.938484342D-01, 5.542730855D-01,6.139943258D-01/ DATA CHECK(28),CHECK(29),CHECK(30),CHECK(31),CHECK(32),CHECK(33), & CHECK(34),CHECK(35),CHECK(36) & /6.716759250D-01, 7.259816530D-01, 7.755752797D-01, & 8.191205752D-01, 8.556270903D-01, 8.854875002D-01, & 9.094402609D-01, 9.282238286D-01, 9.425766596D-01/ DATA CHECK(37),CHECK(38),CHECK(39),CHECK(40),CHECK(41),CHECK(42), & CHECK(43),CHECK(44),CHECK(45) & /9.532372098D-01, 9.609439355D-01, 9.664352927D-01, & 9.704497377D-01, 9.737257265D-01, 9.768786393D-01, & 9.800315521D-01, 9.831844649D-01, 9.863373777D-01/ DATA CHECK(46),CHECK(47),CHECK(48),CHECK(49),CHECK(50), & CHECK(51) & /9.894902905D-01, 9.926011645D-01, 9.954598055D-01, & !***FIRST EXECUTABLE STATEMENT DFCQX 9.978139804D-01, 9.994114563D-01, 1.000000000D+00/ if ( kprint >= 2) write (LUN,9000) ! ! Broadcast SDDATA(1) value to all of SDDATA(*). ! ipass = 1 call DCOPY(NDATA,SDDATA,0,SDDATA,1) ZERO = 0 ONE = 1 ! ! Write the various constraints for the fitted curve. ! NDEG = NORD - 1 NCONST = 0 ! ! Constrain function to be zero at left-most breakpoint. ! T = BKPT(NORD) NCONST = NCONST + 1 XCONST(NCONST) = T YCONST(NCONST) = ZERO ! ! Constrain first derivative to be nonnegative at left-most ! breakpoint. ! NDERIV(NCONST) = 2 + 4*0 NCONST = NCONST + 1 XCONST(NCONST) = T YCONST(NCONST) = ZERO ! ! Constrain second derivatives to be nonnegative at left set of ! breakpoints. ! NDERIV(NCONST) = 1 + 4*1 DO 10 I = 1,3 L = NDEG + I T = BKPT(L) NCONST = NCONST + 1 XCONST(NCONST) = T YCONST(NCONST) = ZERO NDERIV(NCONST) = 1 + 4*2 ! ! Constrain function value at right-most breakpoint to be one. ! 10 continue NCONST = NCONST + 1 T = BKPT(LAST) XCONST(NCONST) = T YCONST(NCONST) = ONE ! ! Constrain slope to agree at left- and right-most breakpoints. ! NDERIV(NCONST) = 2 + 4*0 NCONST = NCONST + 1 XCONST(NCONST) = BKPT(NORD) YCONST(NCONST) = BKPT(LAST) ! ! Constrain second derivatives to be nonpositive at right set of ! breakpoints. ! NDERIV(NCONST) = 3 + 4*1 DO 20 I = 1,4 NCONST = NCONST + 1 L = LAST - 4 + I XCONST(NCONST) = BKPT(L) YCONST(NCONST) = ZERO NDERIV(NCONST) = 0 + 4*2 ! 20 continue ! IDIGIT = -4 if ( kprint >= 3 ) then call DVOUT (NBKPT,BKPT,'('' ARRAY OF KNOTS.'')',IDIGIT) call DVOUT (NDATA,XDATA, & '('' INDEPENDENT VARIABLE VALUES'')',IDIGIT) call DVOUT (NDATA,YDATA,'('' DEPENDENT VARIABLE VALUES'')', & IDIGIT) call DVOUT (NDATA,SDDATA, & '('' DEPENDENT VARIABLE UNCERTAINTY'')',IDIGIT) call DVOUT (NCONST,XCONST, & '('' INDEPENDENT VARIABLE CONSTRAINT VALUES'')', & IDIGIT) call DVOUT (NCONST,YCONST,'('' CONSTRAINT VALUES'')',IDIGIT) call IVOUT (NCONST,NDERIV,'('' CONSTRAINT INDICATOR'')',IDIGIT) ! ! Declare amount of working storage allocated to DFC. ! end if IW(1) = 529 ! ! Set mode to indicate a new problem and request the variance ! function. ! IW(2) = 30 ! ! Obtain the coefficients of the B-spline. ! MODE = 2 call DFC(NDATA,XDATA,YDATA,SDDATA,NORD,NBKPT,BKPT,NCONST,XCONST, & ! ! Check coefficients. ! YCONST,NDERIV,MODE,COEFF,W,IW) TOL = max ( 7.0D0*SQRT(d1mach(4)),1.0D-8) DIFF = 0.0D0 DO 30 I = 1,NDATA DIFF = max ( DIFF,ABS(COEFF(I)-COEFCK(I))) 30 continue if ( DIFF <= TOL ) then FATAL = .FALSE. if ( kprint >= 3) write (LUN,9010) else ipass = 0 FATAL = .TRUE. if ( kprint >= 2) write (LUN,9020) ! end if if ( (FATAL .and. KPRINT >= 2) .OR. KPRINT>=3 ) then call DVOUT (NDATA,COEFCK, & '(/'' PREDICTED COEFFICIENTS OF THE B-SPLINE '// & 'FROM SAMPLE'')',IDIGIT) call DVOUT (NDATA,COEFF, & '(/'' COEFFICIENTS OF THE B-SPLINE COMPUTED '// & 'BY DFC'')',IDIGIT) ! ! Compute value, first two derivatives and probable uncertainty. ! end if N = NBKPT - NORD NVAL = 51 ! ! The function DBVALU is in the de Boor B-spline package. ! DO 70 I = 1,NVAL XVAL = DBLE(I-1)/(NVAL-1) II = 1 DO 60 J = 1,3 V(I,J+1) = DBVALU(BKPT,COEFF,N,NORD,J-1,XVAL,II,WORK) 60 continue ! ! The variance function DCV is a companion subprogram to DFC. ! V(I,1) = XVAL V(I,5) = SQRT(DCV(XVAL,NDATA,NCONST,NORD,NBKPT,BKPT,W)) ! 70 continue DIFF = 0.0D0 DO 80 I = 1,NVAL DIFF = max ( DIFF,ABS(V(I,2)-CHECK(I))) 80 continue if ( DIFF <= TOL ) then FATAL = .FALSE. if ( kprint >= 3) write (LUN,9030) else ipass = 0 FATAL = .TRUE. if ( kprint >= 2) write (LUN,9040) end if ! ! Print these values. ! if ( (FATAL .and. KPRINT >= 2) .OR. KPRINT>=3 ) then call DMOUT(NVAL,5,NVAL,V,'(16X, ''X'', 10X, ''FNCN'', 8X,' // & '''1ST D'', 7X, ''2ND D'', 7X, ''ERROR'')',IDIGIT) write (LUN,9050) ! ! Trigger 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, 9060) call DFC(NDATA,XDATA,YDATA,SDDATA,0,NBKPT,BKPT,NCONST,XCONST, & YCONST,NDERIV,MODE,COEFF,W,IW) if ( NUMXER(NERR) /= 2) FATAL = .TRUE. ! call xerclr call DFC(NDATA,XDATA,YDATA,SDDATA,NORD,0,BKPT,NCONST,XCONST, & YCONST,NDERIV,MODE,COEFF,W,IW) if ( NUMXER(NERR) /= 2) FATAL = .TRUE. ! call xerclr call DFC(-1,XDATA,YDATA,SDDATA,NORD,NBKPT,BKPT,NCONST,XCONST, & YCONST,NDERIV,MODE,COEFF,W,IW) if ( NUMXER(NERR) /= 2) FATAL = .TRUE. ! call xerclr MODE = 0 call DFC(NDATA,XDATA,YDATA,SDDATA,NORD,NBKPT,BKPT,NCONST,XCONST, & YCONST,NDERIV,MODE,COEFF,W,IW) if ( NUMXER(NERR) /= 2) FATAL = .TRUE. ! call xerclr IW(1) = 10 call DFC(NDATA,XDATA,YDATA,SDDATA,NORD,NBKPT,BKPT,NCONST,XCONST, & YCONST,NDERIV,MODE,COEFF,W,IW) if ( NUMXER(NERR) /= 2) FATAL = .TRUE. ! call xerclr IW(1) = 529 IW(2) = 2 call DFC(NDATA,XDATA,YDATA,SDDATA,NORD,NBKPT,BKPT,NCONST,XCONST, & YCONST,NDERIV,MODE,COEFF,W,IW) if ( NUMXER(NERR) /= 2) FATAL = .TRUE. ! ! Restore KONTRL and check to see if the tests of error detection ! passed. ! call xerclr call XSETF (KONTRL) if ( FATAL ) then ipass = 0 if ( kprint >= 2 ) then write (LUN, 9070) end if else if ( kprint >= 3 ) then write (LUN, 9080) end if ! ! Print PASS/FAIL message. ! end if if ( ipass == 1 .and. KPRINT >= 2) write (LUN,9100) if ( ipass == 0 .and. KPRINT >= 1) write (LUN,9110) ! return 9000 FORMAT ('1' / ' Test DFC') 9010 FORMAT (/ ' DFC PASSED TEST 1') 9020 FORMAT (/ ' DFC FAILED TEST 1') 9030 FORMAT (/ ' DFC (AND DBVALU) PASSED TEST 2') 9040 FORMAT (/ ' DFC (AND DBVALU) FAILED TEST 2') 9050 FORMAT (/ ' VALUES SHOULD CORRESPOND TO THOSE IN ','SAND78-1291,', & ' P. 26') 9060 FORMAT (/ ' TRIGGER 6 ERROR MESSAGES',/) 9070 FORMAT (' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 9080 FORMAT (' ALL INCORRECT ARGUMENT TESTS PASSED') 9100 FORMAT (/' ****************DFC PASSED ALL TESTS*****************') 9110 FORMAT (/' ***************DFC FAILED SOME TESTS*****************') end !! DFDEQC !***SUBSIDIARY !***PURPOSE Derivative evaluator for DDEPAC quick checks. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (FDEQC-S, DFDEQC-D) !***AUTHOR Chow, Jeff, (LANL) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900415 Name changed from DDF to DFDEQC. (WRB) !***END PROLOGUE DFDEQC ! ! Declare arguments. ! subroutine DFDEQC (T, U, UPRIME, RPAR, IPAR) integer IPAR(*) ! ! Declare local variables. ! double precision RPAR(*), T, U(*), UPRIME(*) !***FIRST EXECUTABLE STATEMENT DFDEQC double precision R, RSQ, R3 RSQ = U(1)*U(1) + U(2)*U(2) R = SQRT(RSQ) R3 = RSQ*R UPRIME(1) = U(3) UPRIME(2) = U(4) UPRIME(3) = -(U(1)/R3) UPRIME(4) = -(U(2)/R3) return end !! DFDTRU !***SUBSIDIARY !***PURPOSE Compute exact function values for DEVCHK. !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (FDTRUE-S, DFDTRU-D) !***KEYWORDS PCHIP EVALUATOR QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! COMPUTE EXACT FUNCTION VALUES IN DOUBLE PRECISION. ! ! F(X) = X*(X+1)*(X-2) ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 890706 Cosmetic changes to prologue. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900315 Revised prologue. (FNF) ! 900316 Deleted variables ONE and TWO. (FNF) ! 900321 Changed name of d.p. version from DFTRUE to DFDTRU. !***END PROLOGUE DFDTRU subroutine DFDTRU (X, F, D) double precision X, F, D ! !***FIRST EXECUTABLE STATEMENT DFDTRU double precision FACT1, FACT2, XX XX = X FACT1 = XX + 1 FACT2 = XX - 2 F = XX * FACT1 * FACT2 ! D = FACT1*FACT2 + XX*(FACT1 + FACT2) ! -------- LAST LINE OF DFDTRU FOLLOWS ----------------------------- return end !! DFEIN !***PURPOSE Subsidiary to DEG8CK. !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***COMMON BLOCKS DFEINX !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DFEIN double precision FUNCTION DFEIN (T) COMMON /DFEINX/ X, A, FKM !***FIRST EXECUTABLE STATEMENT DFEIN double precision X, A, FKM, T, ALN ALN = (FKM-T)*X - A*LOG(T) DFEIN = EXP(ALN) return end !! DFILL !***SUBSIDIARY !***PURPOSE Fill a vector with a value. !***LIBRARY SLATEC (SLAP) !***TYPE DOUBLE PRECISION (VFILL-S, DFILL-D) !***AUTHOR Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-300 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***DESCRIPTION ! ! *Usage: ! INTEGER N ! DOUBLE PRECISION V(N), VAL ! ! call DFILL( N, V, VAL ) ! ! *Arguments: ! N :IN Integer. ! Length of the vector ! V :OUT Double Precision V(N). ! Vector to be set. ! VAL :IN Double Precision. ! Value to seed the vector with. !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890920 Converted prologue to SLATEC 4.0 format. (FNF) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE DFILL ! .. Scalar Arguments .. subroutine DFILL (N, V, VAL) double precision VAL ! .. Array Arguments .. integer N ! .. Local Scalars .. double precision V(*) ! .. Intrinsic Functions .. integer I, IS, NR !***FIRST EXECUTABLE STATEMENT DFILL INTRINSIC MOD if ( N <= 0) RETURN ! ! The following construct assumes a zero pass do loop. ! NR=MOD(N,4) IS=1 GOTO(1,2,3,4), NR+1 4 IS=4 V(1)=VAL V(2)=VAL V(3)=VAL GOTO 1 3 IS=3 V(1)=VAL V(2)=VAL GOTO 1 2 IS=2 V(1)=VAL 1 DO 10 I=IS,N,4 V(I) =VAL V(I+1)=VAL V(I+2)=VAL V(I+3)=VAL 10 continue ! -------- LAST LINE OF DFILL FOLLOWS ----------------------------- return end !! DFMAT !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***COMMON BLOCKS DSAVEX !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DFMAT subroutine DFMAT (X, Y, YP) double precision X,Y,YP,XSAVE,TERM,TANX dimension Y(*),YP(*) !***FIRST EXECUTABLE STATEMENT DFMAT COMMON /DSAVEX/ XSAVE, TERM YP(1) = Y(2) if ( X == XSAVE) GO TO 10 XSAVE=X TANX= TAN(X/57.2957795130823D0) TERM= 3.0D0/TANX+2.0D0*TANX 10 YP(2) = -TERM*Y(2)-0.7D0*Y(1) return end !! DFNCK !***PURPOSE Quick check for the double precision Fullerton ! special functions. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Boland, W. Robert, (LANL) ! Chow, Jeff, (LANL) !***DESCRIPTION ! ! This subroutine does a quick check for the double precision ! routines in the Fullerton special function library. ! ! Parameter list- ! ! LUN input integer value to designate the external ! device unit for message output ! kprint input integer value to specify amount of ! printing to be done by quick check ! ipass output value indicating whether tests passed or ! failed ! !***ROUTINES CALLED d1mach, D9ATN1, D9LN2R, DACOSH, DAI, DAIE, DASINH, ! DATANH, DBESI0, DBESI1, DBESJ0, DBESJ1, DBESK0, ! DBESK1, DBESKS, DBESY0, DBESY1, DBETA, DBETAI, DBI, ! DBIE, DBINOM, DBSI0E, DBSI1E, DBSK0E, DBSK1E, ! DBSKES, DCBRT, DCHU, DCOSDG, DCOT, DDAWS, DE1, DEI, ! DERF, DEXPRL, DFAC, DGAMI, DGAMIC, DGAMIT, DGAMMA, ! DGAMR, DLI, DLNREL, DPOCH, DPOCH1, DPSI, DSINDG, ! DSPENC !***REVISION HISTORY (YYMMDD) ! 800801 DATE WRITTEN ! 891115 REVISION DATE from Version 3.2 ! 891120 Checks of remainder of FNLIB routines added and code ! reorganized. (WRB) ! 900330 Prologue converted to Version 4.0 format. (BAB) ! 900727 Added EXTERNAL statement. (WRB) !***END PROLOGUE DFNCK subroutine DFNCK (LUN, KPRINT, IPASS) integer I, lun, kprint, ipass double precision d1mach, & Y(105),V(105),ERRMAX,ERRTOL,ABSERR,RELERR, & D9ATN1,D9LN2R,DACOSH,DAI,DAIE,DASINH,DATANH, & DBESI0,DBESI1,DBESJ0,DBESJ1,DBESK0,DBESK1, & DBESY0,DBESY1,DBETA,DBETAI,DBI,DBIE,DBINOM, & DBSI0E,DBSI1E,DBSK0E,DBSK1E,DCBRT,DCHU,DCOSDG, & DCOT,DDAWS,DE1,DEI,DERF,DEXPRL,DFAC,DGAMI,DGAMIC, & DGAMIT,DGAMMA,DGAMR,DLI,DLNREL,DPOCH,DPOCH1,DPSI, & DSINDG,DSPENC ! ! Correct values through different calculations are stored in V(*) ! EXTERNAL DCOT, DERF, DGAMMA DATA V( 1) / .834451800000000000000000000000D+09/ DATA V( 2) / .225082957512000000000000000000D+13/ DATA V( 3) / .130767436800000000000000000000D+13/ DATA V( 4) / .822283865417792281772556288000D+34/ DATA V( 5) /-.200000000000000000000000000000D+01/ DATA V( 6) / .998340790000000000000000000000D+02/ DATA V( 7) / .866025403784438646763723170753D+00/ DATA V( 8) /-.707106781186547524400844362105D+00/ DATA V( 9) / .642092615934330703006419986594D+00/ DATA V( 10) /-.183048772171245191926801943897D+01/ DATA V( 11) /-.290819127993551070285950148310D+00/ DATA V( 12) /-.111606410275738687122866817478D+00/ DATA V( 13) / .500000000000000000000000000000D+00/ DATA V( 14) / .707106781186547524400844362105D+00/ DATA V( 15) / .137149838147233638243285631505D+00/ DATA V( 16) /-.100000050000033333358333416027D-05/ DATA V( 17) / .100125104231803398984880296644D+01/ DATA V( 18) / .995016625083194642609402280122D+00/ DATA V( 19) / .243720864865315055824104923715D+00/ DATA V( 20) / .193147180559945309417232121458D+00/ DATA V( 21) / .111112222233333444440000000000D+00/ DATA V( 22) / .314159265359000000000000000000D+01/ DATA V( 23) / .998340790000000000000000000000D-01/ DATA V( 24) /-.119476321700000000000000000000D+01/ DATA V( 25) /-.111112222233333444440000000000D+00/ DATA V( 26) / .264665241200000000000000000000D+01/ DATA V( 27) /-.378671043061087976727207184637D+00/ DATA V( 28) / .104516378011749278484458888919D+01/ DATA V( 29) / .559773594776160811746795939295D+00/ DATA V( 30) / .100019582406632651901909339800D+00/ DATA V( 31) / .454219904863173579920523812663D+00/ DATA V( 32) / .189511781635593675546652093433D+01/ DATA V( 33) / .582240526465012505902656320160D+00/ DATA V( 34) / .164493406684822643647241516665D+01/ DATA V( 35) / .886226925452758013649083741687D+00/ DATA V( 36) /-.314159265358979323846264338328D+01/ DATA V( 37) / .318309886183790671537767526733D+00/ DATA V( 38) / .882395720020380090550940262394D-06/ DATA V( 39) /-.282094791773878143474039725759D+00/ DATA V( 40) / .187500000000000000000000000000D+01/ DATA V( 41) / .513516668382050295584635612122D-01/ DATA V( 42) / .598750000000000000000000000000D+02/ DATA V( 43) / .157079632679489661923132169164D+01/ DATA V( 44) / .755006169037464042751871235437D-03/ DATA V( 45) / .422784335098467139393487909918D+00/ DATA V( 46) / .230300103429768637527259355045D+01/ DATA V( 47) / .999856618263723706885830759463D+00/ DATA V( 48) / .888290707183956735878281870759D+00/ DATA V( 49) / .135335283236612691893999494971D+00/ DATA V( 50) / .346930306295801456170933128256D-03/ DATA V( 51) / .786938680574733152792400930048D+00/ DATA V( 52) / .631673391775258123291222663623D-01/ DATA V( 53) / .381281566461770916149261183171D+00/ DATA V( 54) / .265625000000000000000000000000D+00/ DATA V( 55) / .520499877813046537682746653770D+00/ DATA V( 56) / .888388231701707764069578446749D+00/ DATA V( 57) / .424436383502022295934042352455D+00/ DATA V( 58) / .337000659742093423383019719632D+00/ DATA V( 59) /-.177596771314338304347397013056D+00/ DATA V( 60) / .223890779141235668051827454628D+00/ DATA V( 61) /-.327579137591465222037734321812D+00/ DATA V( 62) / .576724807756873387202448242187D+00/ DATA V( 63) / .510375672649745119596606592612D+00/ DATA V( 64) /-.308517625249033780073648984210D+00/ DATA V( 65) / .147863143391226844801050675510D+00/ DATA V( 66) /-.107032431540937546888370772230D+00/ DATA V( 67) / .227958530233606726743720444020D+01/ DATA V( 68) / .272398718236044468945442320700D+02/ DATA V( 69) / .159063685463732906338225442450D+01/ DATA V( 70) / .243356421424505271991430504400D+02/ DATA V( 71) / .113893872749533435652719574910D+00/ DATA V( 72) / .369109833404259427473526100740D-02/ DATA V( 73) / .139865881816522427284598806997D+00/ DATA V( 74) / .404461344545216420836502183700D-02/ DATA V( 75) / .308508322553671039533384319255D+00/ DATA V( 76) / .183540812609328353073650751820D+00/ DATA V( 77) / .163972266944542356926122903850D+00/ DATA V( 78) / .215269289248937659158505143243D+00/ DATA V( 79) / .841568215070771417919124867127D+00/ DATA V( 80) / .547807564313518986868201568700D+00/ DATA V( 81) / .600273858788312582936045656600D+00/ DATA V( 82) / .103347684706868857317535710603D+01/ DATA V( 83) / .886226925452758013649083741000D+00/ DATA V( 84) / .132934038817913702047362561200D+01/ DATA V( 85) / .288023750772146354435952215970D+01/ DATA V( 86) / .560499121639792869931128243359D+00/ DATA V( 87) / .672598945967751443917353892000D+00/ DATA V( 88) / .964058489220443736281540578570D+00/ DATA V( 89) / .461068504447894558439575873876D+00/ DATA V( 90) / .922137008895789116879151747751D+00/ DATA V( 91) / .231693606480833489769125254500D+00/ DATA V( 92) / .157259233804704899952660465400D-01/ DATA V( 93) / .293277159129947362450897433147D+00/ DATA V( 94) / .219322205128712060862850888400D+00/ DATA V( 95) / .854277043103155493300048798776D+00/ DATA V( 96) / .187894150374789500090933504950D+01/ DATA V( 97) / .674892411115630212865414309867D+00/ DATA V( 98) / .464750480196092515019775411670D+00/ DATA V( 99) / .249999999999999999999999999880D+00/ DATA V(100) / .735008609300377745369706799000D+00/ DATA V(101) / .406961787650672979742685260000D+00/ DATA V(102) / .448256669291582953916931735480D+00/ DATA V(103) / .596347362323194074341078499290D+00/ DATA V(104) / .757342086122175953454414369190D+00/ !***FIRST EXECUTABLE STATEMENT DFNCK ! ! Compute functional values ! ! Exercise routines in Category C1. ! DATA V(105) / .757872156141312106043351240000D+00/ Y( 1) = DBINOM(35,12) Y( 2) = DBINOM(50,15) Y( 3) = DFAC(15) ! ! Exercise routines in Category C2 ! Y( 4) = DFAC(31) Y( 5) = DCBRT(-8.D0) ! ! Exercise routines in Category C4A. ! Y( 6) = DCBRT(.995030624365703964475039000000D6) Y( 7) = DCOSDG(30.D0) Y( 8) = DCOSDG(135.D0) Y( 9) = DCOT(1.D0) Y( 10) = DCOT(-.5D0) Y( 11) = D9ATN1(.5D0) Y( 12) = D9ATN1(2.D0) Y( 13) = DSINDG(30.D0) ! ! Exercise routines in Category C4B. ! Y( 14) = DSINDG(135.D0) Y( 15) = DLNREL(.147D0) Y( 16) = DLNREL(-.1D-5) Y( 17) = DEXPRL(.25D-2) Y( 18) = DEXPRL(-.1D-1) Y( 19) = D9LN2R(.5D0) ! ! Exercise routines in Category C4C. ! Y( 20) = D9LN2R(1.D0) Y( 21) = DACOSH(.100617931649094823747218929626D1) Y( 22) = DACOSH(.115919532755239084628557897777D2) Y( 23) = DASINH(.100000000101295145211538706587D0) Y( 24) = DASINH(-.149999999948240634124264852207D1) Y( 25) = DATANH(-.110657208041383998066515207788D0) ! ! Exercise routines in Category C5. ! Y( 26) = DATANH(.989999999992791300663084082410D0) Y( 27) = DLI(.5D0) Y( 28) = DLI(2.D0) Y( 29) = DE1(.5D0) Y( 30) = DE1(1.5D0) Y( 31) = DEI(.5D0) Y( 32) = DEI(1.D0) Y( 33) = DSPENC(.5D0) Y( 34) = DSPENC(1.D0) Y( 35) = DGAMMA(1.5D0) Y( 36) = DGAMMA(-.5D0)*DGAMMA(1.5D0) Y( 37) = DGAMR(-1.5D0)*DGAMR(2.5D0) ! ! Exercise routines in Category C7A. ! Y( 38) = DGAMR(10.5D0) Y( 39) = DPOCH(-.5D0,1.5D0) Y( 40) = DPOCH(.5D0,3.D0) Y( 41) = DPOCH1(.5D0,2.5D0) ! ! Exercise routines in Category C7B. ! Y( 42) = DPOCH1(10.5D0,2.D0) Y( 43) = DBETA(.5D0,1.5D0) ! ! Exercise routines in Category C7C. ! Y( 44) = DBETA(5.5D0,5.5D0) Y( 45) = DPSI(2.D0) ! ! Exercise routines in Category C7E. ! Y( 46) = DPSI(10.5D0) Y( 47) = DGAMI(1.D0,8.85D0) Y( 48) = DGAMI(2.D0,3.75D0) Y( 49) = DGAMIC(1.D0,2.D0) Y( 50) = DGAMIC(2.D0,10.4D0) Y( 51) = DGAMIT(1.D0,.5D0) ! ! Exercise routines in Category C7F. ! Y( 52) = DGAMIT(2.D0,3.75D0) Y( 53) = DBETAI(.5D0,2.D0,1.5D0) ! ! Exercise routines in Category C8A. ! Y( 54) = DBETAI(.25D0,1.5D0,2.D0) Y( 55) = DERF(.5D0) ! ! Exercise routines in Category C8C. ! Y( 56) = DERF(1.125D0) Y( 57) = DDAWS(.5D0) ! ! Exercise routines in Category C10A1. ! Y( 58) = DDAWS(1.84D0) Y( 59) = DBESJ0(5.D0) Y( 60) = DBESJ0(2.D0) Y( 61) = DBESJ1(5.D0) Y( 62) = DBESJ1(2.D0) Y( 63) = DBESY0(2.D0) Y( 64) = DBESY0(5.D0) Y( 65) = DBESY1(5.D0) ! ! Exercise routines in Category C10B1. ! Y( 66) = DBESY1(2.D0) Y( 67) = DBESI0(2.D0) Y( 68) = DBESI0(5.D0) Y( 69) = DBESI1(2.D0) Y( 70) = DBESI1(5.D0) Y( 71) = DBESK0(2.D0) Y( 72) = DBESK0(5.D0) Y( 73) = DBESK1(2.D0) Y( 74) = DBESK1(5.D0) Y( 75) = DBSI0E(2.D0) Y( 76) = DBSI0E(5.D0) Y( 77) = DBSI1E(5.D0) Y( 78) = DBSI1E(2.D0) Y( 79) = DBSK0E(2.D0) Y( 80) = DBSK0E(5.D0) Y( 81) = DBSK1E(5.D0) ! ! Exercise routines in Category C10B3. ! Y( 82) = DBSK1E(2.D0) call DBSKES(.5D0,2.D0,3,Y(83)) call DBSKES(.5D0,5.D0,3,Y(86)) ! ! Exercise routines in Category C10D. ! call DBESKS(.5D0,1.D0,2,Y(89)) Y( 91) = DAI(.5D0) Y( 92) = DAI(2.5D0) Y( 93) = DAIE(.5D0) Y( 94) = DAIE(2.5D0) Y( 95) = DBI(.5D0) Y( 96) = DBI(1.5D0) Y( 97) = DBIE(.5D0) ! ! Exercise routines in Category C11. ! Y( 98) = DBIE(2.5D0) Y( 99) = DCHU(1.D0,2.D0,4.D0) Y(100) = DCHU(5.D0/6.D0,5.D0/3.D0,4.D0/3.D0) Y(101) = DCHU(.75D0,.75D0,2.5D0) Y(102) = DCHU(1.D0,1.D0,1.5D0) Y(103) = DCHU(1.D0,1.D0,1.D0) Y(104) = DCHU(1.D0,1.D0,-LOG(.5D0)) ! ! Check for possible errors ! Y(105) = DCHU(.5D0,.5D0,1.D0) ERRMAX = d1mach(4) ERRTOL = SQRT(ERRMAX) DO 10 I = 1,105 ABSERR = ABS(V(I)-Y(I)) RELERR = ABSERR/ABS(V(I)) ERRMAX = max ( RELERR,ERRMAX) if ( RELERR > ERRTOL .and. KPRINT >= 2) & write (LUN,620) I,RELERR,ABSERR 10 continue ipass = 0 if ( ERRMAX <= ERRTOL) ipass = 1 if ( ipass /= 0 .and. KPRINT >= 2) write (LUN,610) return 610 FORMAT (' Double precision Fullerton special function ', & ' routines o.k.') 620 FORMAT (' For I = ', I3, ' test fails with RELERR = ', & D38.30, ' and ABSERR = ', D38.30) end !! DFQD1 !***SUBSIDIARY !***PURPOSE Function evaluator for DQNC79 and DGAUS8 quick checks. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (FQD1-S, DFQD1-D) !***AUTHOR Boland, W. Robert, (LANL) !***SEE ALSO DQG8TS, DQN79Q !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 920229 DATE WRITTEN !***END PROLOGUE DFQD1 ! .. Scalar Arguments .. double precision FUNCTION DFQD1 (X) ! .. Intrinsic Functions .. double precision X !***FIRST EXECUTABLE STATEMENT DFQD1 INTRINSIC SQRT DFQD1 = 0.0D0 if ( X > 0.0D0 ) then DFQD1 = 1.0D0/SQRT(X) end if return end !! DFQD2 !***SUBSIDIARY !***PURPOSE Function evaluator for DQNC79 and DGAUS8 quick checks. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (FQD2-S, DFQD2-D) !***AUTHOR Boland, W. Robert, (LANL) !***SEE ALSO DQG8TS, DQN79Q !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 920229 DATE WRITTEN !***END PROLOGUE DFQD2 ! .. Scalar Arguments .. double precision FUNCTION DFQD2 (X) ! .. Intrinsic Functions .. double precision X !***FIRST EXECUTABLE STATEMENT DFQD2 INTRINSIC COS,EXP DFQD2 = EXP(X)*COS(10.0D0*X) return end !! DFZTST !***PURPOSE Quick check for DFZERO. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (FZTEST-S, DFZTST-D) !***AUTHOR Boland, W. Robert, (LANL) !***ROUTINES CALLED d1mach, DFZERO, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 920212 DATE WRITTEN !***END PROLOGUE DFZTST ! .. Scalar Arguments .. subroutine DFZTST (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN integer IFLAG, KONTRL double precision AE, B, C, PI, R, RE, TOL ! .. External Functions .. LOGICAL FATAL double precision d1mach ! .. External Subroutines .. EXTERNAL d1mach ! .. Intrinsic Functions .. EXTERNAL DFZERO, XERCLR, XGETF, XSETF !***FIRST EXECUTABLE STATEMENT DFZTST INTRINSIC ABS, ATAN, DSIN, DTAN, MAX, SQRT if ( kprint >= 2) write (LUN,9000) ipass = 1 PI = 4.0D0 *ATAN(1.0D0) RE = 1.0D-10 AE = 1.0D-10 ! ! Set up and solve example problem ! TOL = max ( 1.0D-9,SQRT(d1mach(4))) B = 0.1D0 C = 4.0D0 R = C - B ! ! See if test was passed. ! call DFZERO (DSIN, B, C, R, RE, AE, IFLAG) if ( ABS(B-PI) <= TOL .and. ABS(C-PI) <= TOL ) then if ( kprint >= 3) write (LUN, 9010) 'PASSED', B, C, IFLAG else ipass = 0 if ( kprint >= 2) write (LUN, 9010) 'FAILED', B, C, IFLAG ! ! Trigger 2 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,9020) ! ! IFLAG=3 (Singular point) ! B = 1.0D0 C = 2.0D0 R = 0.5D0*(B+C) call DFZERO (DTAN, B, C, B, RE, AE, IFLAG) if ( IFLAG /= 3 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 2) write (LUN,9030) IFLAG, 2 ! ! IFLAG=4 (No sign change) ! end if B = -3.0D0 C = -0.1D0 R = 0.5D0*(B+C) call DFZERO (DSIN, B, C, R, RE, AE, IFLAG) if ( IFLAG /= 4 ) then ipass = 0 FATAL = .TRUE. if ( kprint >= 2) write (LUN,9030) IFLAG, 4 ! end if ! call xerclr call XSETF (KONTRL) if ( FATAL ) then if ( kprint >= 2 ) then write (LUN, 9040) end if else if ( kprint >= 3 ) then write (LUN, 9050) end if ! end if if ( ipass == 1 .and. KPRINT >= 2) write (LUN,9060) if ( ipass == 0 .and. KPRINT >= 1) write (LUN,9070) return 9000 FORMAT ('1' / ' DFZERO QUICK CHECK') 9010 FORMAT (' Accuracy test ', A / & ' Example problem results: (answer = PI), B =', F20.14, & ' C =', F20.14 / ' IFLAG =', I2) 9020 FORMAT (/ ' IFLAG 3 and 4 tests') 9030 FORMAT (/' IFLAG test FAILED. IFLAG =', I2, ', but should ', & 'have been', I2) 9040 FORMAT (/ ' At least IFLAG test failed') 9050 FORMAT (/ ' All IFLAG tests passed') 9060 FORMAT (/' ***************DFZERO PASSED ALL TESTS**************') 9070 FORMAT (/' ***************DFZERO FAILED SOME TESTS*************') end !! DGEQC !***PURPOSE Quick check for DGEFS. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SGEQC-S, DGEQC-D, CGEQC-C) !***KEYWORDS QUICK CHECK !***AUTHOR Jacobsen, Nancy, (LANL) !***DESCRIPTION ! ! Let A*X=B be a DOUBLE PRECISION linear system where the ! matrix is of the proper type for the Linpack subroutines ! being called. The values of A and B and the pre-computed ! values of BXEX (the solution vector) are given in DATA ! statements. The computed test results for X are compared to ! the stored pre-computed values. Failure of the test occurs ! when there is less than 80% agreement between the absolute ! values. There are 2 tests - one for the normal case and one ! for the singular case. A message is printed indicating ! whether each subroutine has passed or failed for each case. ! ! On return, NERR (INTEGER type) contains the total count of ! all failures detected. ! !***ROUTINES CALLED d1mach, DGEFS !***REVISION HISTORY (YYMMDD) ! 801022 DATE WRITTEN ! 891009 Removed unreferenced statement label. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920601 Code reworked and TYPE section added. (RWC, WRB) !***END PROLOGUE DGEQC ! .. Scalar Arguments .. subroutine DGEQC (LUN, KPRINT, NERR) ! .. Local Scalars .. integer KPRINT, LUN, NERR double precision ERRCMP, ERRMAX ! .. Local Arrays .. integer I, IND, ITASK, J, KPROG, LDA, N double precision A(5,4), ATEMP(5,4), B(4), BTEMP(4), BXEX(4), & WORK(20) integer IWORK(4) ! .. External Functions .. CHARACTER LIST(2)*4 double precision d1mach ! .. External Subroutines .. EXTERNAL d1mach ! .. Intrinsic Functions .. EXTERNAL DGEFS ! .. Data statements .. INTRINSIC ABS, MAX DATA A /5.0D0, 1.0D0, 0.3D0, 2.1D0, 0.0D0, & -1.0D0, -0.5D0, 1.0D0, 1.0D0, 0.0D0, & 4.5D0, -1.0D0, -1.7D0, 2.0D0, 0.0D0, & 0.5D0, 2.0D0, 0.6D0, 1.3D0, 0.0D0/ DATA B /0.0D0, 3.5D0, 3.6D0, 2.4D0/ DATA BXEX /0.10D+01, 0.10D+01, -0.10D+01, 0.10D+01/ !***FIRST EXECUTABLE STATEMENT DGEQC DATA LIST /'GEFS', 'GEIR'/ N = 4 LDA = 5 NERR = 0 ERRCMP = d1mach(4)**0.8D0 ! if ( kprint >= 2) write (LUN,9000) ! ! First test case - normal ! KPROG = 1 ITASK = 1 BTEMP(1:n) = B(1:n) ATEMP(1:n,1:n) = A(1:n,1:n) call DGEFS (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) if ( IND < 0 ) then if ( kprint >= 2) write (LUN, FMT=9020) LIST(KPROG), IND NERR = NERR + 1 ! ! Calculate error for first test ! end if ! ERRMAX = 0.0D0 DO 130 I=1,N ERRMAX = max ( ERRMAX,ABS(BTEMP(I)-BXEX(I))) 130 continue if ( ERRCMP > ERRMAX ) then if ( kprint >= 3) write (LUN, FMT=9010) LIST(KPROG) else if ( kprint >= 2) write (LUN, FMT=9020) LIST(KPROG), ERRMAX NERR = NERR + 1 ! ! Second test case - singular matrix ! end if ITASK = 1 DO 140 I=1,N BTEMP(I) = B(I) 140 continue DO 160 J=1,N DO 150 I=1,N ATEMP(I,J) = A(I,J) 150 continue 160 continue DO 170 J=1,N ATEMP(1,J) = 0.0D0 170 continue call DGEFS (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) if ( IND == -4 ) then if ( kprint >= 3) write (LUN, FMT=9030) LIST(KPROG) else if ( kprint >= 2) write (LUN, FMT=9040) LIST(KPROG), IND NERR = NERR + 1 end if if ( KPRINT >= 3 .and. NERR == 0) write (LUN,9050) if ( KPRINT >= 2 .and. NERR /= 0) write (LUN,9060) return 9000 FORMAT (//, 2X, 'DGEFS Quick Check' /) 9010 FORMAT (/, 5X, 'D', A, ' Normal test PASSED') 9020 FORMAT (/, 5X, 'D', A, ' Test FAILED, MAX ABS(ERROR) is', E13.5) 9030 FORMAT (/, 5X, 'D', A, ' Singular test PASSED') 9040 FORMAT (/, 5X, 'D', A, ' Singular test FAILED, IND=', I3) 9050 FORMAT (/, 2X, 'DGEFS Quick Check PASSED' /) 9060 FORMAT (/, 2X, 'SGEFS and SGEIR Quick Check FAILED' /) end !! DGVEC !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DGVEC subroutine DGVEC (X, G) double precision X,G !***FIRST EXECUTABLE STATEMENT DGVEC dimension G(*) G(1) = 0.0D0 G(2) = 1.0D0+COS(X) return end !! DJAC !***SUBSIDIARY !***PURPOSE Evaluate Jacobian for DDEBDF quick check. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (JAC-S, DJAC-D) !***AUTHOR Chow, Jeff (LANL) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900415 Minor clean-up of prologue and code and name changed from ! DDJAC to DJAC. (WRB) !***END PROLOGUE DJAC subroutine DJAC (T, U, PD, NROWPD, RPAR, IPAR) integer IPAR, NROWPD double precision PD, R, R5, RPAR, RSQ, T, U, U1SQ, U2SQ, U1U2 !***FIRST EXECUTABLE STATEMENT DJAC dimension U(*), PD(NROWPD,*), RPAR(*), IPAR(*) U1SQ = U(1)*U(1) U2SQ = U(2)*U(2) U1U2 = U(1)*U(2) RSQ = U1SQ + U2SQ R = SQRT(RSQ) R5 = RSQ*RSQ*R PD(3,1) = (3.D0*U1SQ - RSQ)/R5 PD(4,1) = 3.D0*U1U2/R5 PD(3,2) = PD(4,1) PD(4,2) = (3.D0*U2SQ - RSQ)/R5 PD(1,3) = 1.D0 PD(2,4) = 1.D0 return end !! DLAPQC !***PURPOSE Quick check for testing Sparse Linear Algebra Package ! (SLAP) Version 2.0.2. !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE DOUBLE PRECISION (SLAPQC-S, DLAPQC-D) !***KEYWORDS QUICK CHECK, SLAP !***AUTHOR Mark K. Seager (LLNL) ! seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO BOX 808, L-300 ! Livermore, CA 94550 ! (510) 423-3141 !***DESCRIPTION ! ! *Arguments: ! kprint = 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. ! 4 Quick checks - Print complete quick check results. ! Prints matrices, etc. Very verbose!! ! -------------- ! Driver - Pass or fail message printed. ! ! *Description: ! This is a SLATEC Quick Check program to test the *SLAP* ! Version 2.0.2 package. It generates a "random" matrix (See ! DRMGEN) and then runs all the various methods with all the ! various preconditioners and all the various stop tests. ! ! It is assumed that the test is being run interactively and ! that STDIN (STANDARD INPUT) is Fortran I/O unit i1mach(1) ! and STDOUT (STANDARD OUTPUT) is unit i1mach(2). ! ! ************************************************************* ! **** WARNING !!! WARNING !!! WARNING !!! WARNING !!! WARNING ! ************************************************************* ! **** THIS PROGRAM WILL NOT FUNCTION PROPERLY IF THE FORTRAN ! **** I/O UNITS i1mach(1) and i1mach(2) are not connected ! **** to the program for I/O. ! ************************************************************* ! !***REFERENCES (NONE) !***ROUTINES CALLED d1mach, DCPPLT, DFILL, DRMGEN, DS2Y, DSDBCG, DSDCG, ! DSDCGN, DSDCGS, DSDGMR, DSDOMN, DSGS, DSICCG, ! DSILUR, DSJAC, DSLUBC, DSLUCN, DSLUCS, DSLUGM, ! DSLUOM, DUTERR, XERMAX, XSETF, XSETUN !***COMMON BLOCKS DSLBLK !***REVISION HISTORY (YYMMDD) ! 880601 DATE WRITTEN ! 881213 Revised to meet the new SLATEC prologue standards. ! 890920 Modified to reduce single/double differences and to meet ! SLATEC standards, as requested at July 1989 CML Meeting. ! 891003 Reduced MAXN to a more reasonable size for quick check. ! 920401 Made routine a SUBROUTINE and made necessary changes to ! interface with a SLATEC quick check driver. (WRB) ! 920407 COMMON BLOCK renamed DSLBLK. (WRB) ! 920511 Added complete declaration section. (WRB) ! 920602 Eliminated unnecessary variables IOUT and ISTDO and made ! various cosmetic changes. (FNF) ! 920602 Reduced problem size for a shorter-running test and ! corrected lower limit in "DO 80" statement. (FNF) ! 921021 Changed E's to 1P,D's in output formats. (FNF) !***END PROLOGUE DLAPQC ! ! The problem size, MAXN, should be large enough that the ! iterative methods do 10-15 iterations, just to be sure that ! the truncated methods run to the end of their ropes and enter ! their error recovery mode. Thus, for a more thorough test change ! the following PARAMETER statement to: ! PARAMETER (MAXN=69, MXNELT=5000, MAXIW=5000, MAXRW=5000) ! ! .. Parameters .. subroutine DLAPQC (LUN, KPRINT, IPASS) integer MAXN, MXNELT, MAXIW, MAXRW ! .. Scalar Arguments .. PARAMETER (MAXN=25, MXNELT=500, MAXIW=1000, MAXRW=1000) ! .. Arrays in Common .. integer IPASS, KPRINT, LUN ! .. Local Scalars .. double precision SOLN(MAXN) double precision DENS, ERR, FACTOR, TOL integer IERR, ISYM, ITER, ITMAX, ITOL, ITOLGM, IUNIT, K, KASE, & ! .. Local Arrays .. LENIW, LENW, N, NELT, NELTMX, nfail, NMAX, NSAVE double precision A(MXNELT), F(MAXN), RWORK(MAXRW), XITER(MAXN) ! .. External Functions .. integer IA(MXNELT), IWORK(MAXIW), JA(MXNELT) double precision d1mach ! .. External Subroutines .. EXTERNAL d1mach EXTERNAL DCPPLT, DFILL, DRMGEN, DS2Y, DSDBCG, DSDCG, DSDCGN, & DSDCGS, DSDGMR, DSDOMN, DSGS, DSICCG, DSILUR, DSJAC, & ! .. Intrinsic Functions .. DSLUBC, DSLUCN, DSLUCS, DSLUGM, DSLUOM, DUTERR ! .. Common blocks .. INTRINSIC MAX, REAL ! ! The following lines are for the braindamaged Sun FPE handler. ! !$$$ integer oldmode, fpmode !***FIRST EXECUTABLE STATEMENT DLAPQC !$$$ oldmode = fpmode( 62464 ) ! ! Maximum problem sizes. ! COMMON /DSLBLK/ SOLN NELTMX = MXNELT NMAX = MAXN LENIW = MAXIW ! ! Set some input data. ! LENW = MAXRW N = NMAX ITMAX = N ! ! Set to print intermediate results if KPRINT >= 3. ! FACTOR = 1.2D0 if ( kprint < 3 ) then IUNIT = 0 else IUNIT = LUN ! ! Set the Error tolerance to depend on the machine epsilon. ! end if TOL = max ( 1.0D3*d1mach(3),1.0D-6) ! ! Test routines using various convergence criteria. ! nfail = 0 DO 80 KASE = 1, 3 if ( KASE == 1 .OR. KASE == 2) ITOL = KASE ! ! Test routines using nonsymmetric (ISYM=0) and symmetric ! storage (ISYM=1). For ISYM=0 a really non-symmetric matrix ! is generated. The amount of non-symmetry is controlled by ! user. ! if ( KASE == 3) ITOL = 11 DO 70 ISYM = 0, 1 ! ! Set up a random matrix. ! if ( KPRINT >= 2 ) write (LUN, 1050) N, KASE, ISYM call DRMGEN( NELTMX, FACTOR, IERR, N, NELT, & ISYM, IA, JA, A, F, SOLN, RWORK, IWORK, IWORK(N+1) ) if ( IERR /= 0 ) then write (LUN,990) IERR nfail = nfail + 1 GO TO 70 end if if ( ISYM == 0 ) then DENS = REAL(NELT)/(N*N) else DENS = REAL(2*NELT)/(N*N) end if if ( KPRINT >= 2 ) then write (LUN,1020) N, NELT, DENS write (LUN,1030) TOL ! ! Convert to the SLAP-Column format and ! write out matrix in SLAP-Column format, if desired. ! end if call DS2Y( N, NELT, IA, JA, A, ISYM ) if ( KPRINT >= 4 ) then write (LUN,1040) (K,IA(K),JA(K),A(K),K=1,NELT) call DCPPLT( N, NELT, IA, JA, A, ISYM, LUN ) ! !********************************************************************** ! BEGINNING OF SLAP QUICK TESTS !********************************************************************** ! ! * * * * * * DSJAC * * * * * * ! end if if ( KPRINT >= 3 ) then write (LUN,1000) 'DSJAC ', ITOL, ISYM end if call DFILL( N, XITER, 0.0D0 ) call DSJAC(N, F, XITER, NELT, IA, JA, A, ISYM, & ITOL, TOL, 2*ITMAX, ITER, ERR, IERR, IUNIT, & RWORK, LENW, IWORK, LENIW ) ! ! * * * * * DSGS * * * * * ! call DUTERR( 'DSJAC ',IERR,KPRINT,nfail,LUN,ITER,ERR ) if ( KPRINT >= 3 ) then write (LUN,1000) 'DSGS ',ITOL,ISYM end if call DFILL( N, XITER, 0.0D0 ) call DSGS(N, F, XITER, NELT, IA, JA, A, ISYM, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK, LENW, IWORK, LENIW ) ! ! * * * * * * DSILUR * * * * * * ! call DUTERR( 'DSGS ',IERR,KPRINT,nfail,LUN,ITER,ERR ) if ( KPRINT >= 3 ) then write (LUN,1000) 'DSILUR',ITOL,ISYM end if call DFILL( N, XITER, 0.0D0 ) call DSILUR(N, F, XITER, NELT, IA, JA, A, ISYM, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK, LENW, IWORK, LENIW ) ! ! * * * * * * DSDCG * * * * * * ! call DUTERR( 'DSILUR',IERR,KPRINT,nfail,LUN,ITER,ERR ) if ( ISYM == 1 ) then if ( KPRINT >= 3 ) then write (LUN,1000) 'DSDCG',ITOL,ISYM end if call DFILL( N, XITER, 0.0D0 ) call DSDCG(N, F, XITER, NELT, IA, JA, A, ISYM, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK, LENW, IWORK, LENIW ) call DUTERR( 'DSDCG ',IERR,KPRINT,nfail,LUN,ITER,ERR ) ! ! * * * * * * DSICCG * * * * * * ! end if if ( ISYM == 1 ) then if ( KPRINT >= 3 ) then write (LUN,1000) 'DSICCG',ITOL,ISYM end if call DFILL( N, XITER, 0.0D0 ) call DSICCG(N, F, XITER, NELT, IA, JA, A, ISYM, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, & LENW, IWORK, LENIW ) call DUTERR( 'DSICCG',IERR,KPRINT,nfail,LUN,ITER,ERR ) ! ! * * * * * * DSDCGN * * * * * * ! end if if ( KPRINT >= 3 ) then write (LUN,1000) 'DSDCGN',ITOL,ISYM end if call DFILL( N, XITER, 0.0D0 ) call DSDCGN(N, F, XITER, NELT, IA, JA, A, ISYM, ITOL, & TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, & IWORK, LENIW ) ! ! * * * * * * DSLUCN * * * * * * ! call DUTERR( 'DSDCGN',IERR,KPRINT,nfail,LUN,ITER,ERR ) if ( KPRINT >= 3 ) then write (LUN,1000) 'DSLUCN',ITOL,ISYM end if call DFILL( N, XITER, 0.0D0 ) call DSLUCN(N, F, XITER, NELT, IA, JA, A, ISYM, ITOL, & TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, & IWORK, LENIW ) ! ! * * * * * * DSDBCG * * * * * * ! call DUTERR( 'DSLUCN',IERR,KPRINT,nfail,LUN,ITER,ERR ) if ( KPRINT >= 3 ) then write (LUN,1000) 'DSDBCG',ITOL,ISYM end if ! call DFILL( N, XITER, 0.0D0 ) call DSDBCG(N, F, XITER, NELT, IA, JA, A, ISYM, ITOL, & TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, & ! IWORK, LENIW ) ! ! * * * * * * DSLUBC * * * * * * ! call DUTERR( 'DSDBCG',IERR,KPRINT,nfail,LUN,ITER,ERR ) if ( KPRINT >= 3 ) then write (LUN,1000) 'DSLUBC',ITOL,ISYM end if call DFILL( N, XITER, 0.0D0 ) call DSLUBC(N, F, XITER, NELT, IA, JA, A, ISYM, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK, LENW, IWORK, LENIW ) ! ! * * * * * * DSDCGS * * * * * * ! call DUTERR( 'DSLUBC',IERR,KPRINT,nfail,LUN,ITER,ERR ) if ( KPRINT >= 3 ) then write (LUN,1000) 'DSDCGS',ITOL,ISYM end if call DFILL( N, XITER, 0.0D0 ) call DSDCGS(N, F, XITER, NELT, IA, JA, A, ISYM, ITOL, & TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, & IWORK, LENIW ) ! ! * * * * * * DSLUCS * * * * * * ! call DUTERR( 'DSDCGS',IERR,KPRINT,nfail,LUN,ITER,ERR ) if ( KPRINT >= 3 ) then write (LUN,1000) 'DSLUCS',ITOL,ISYM end if call DFILL( N, XITER, 0.0D0 ) call DSLUCS(N, F, XITER, NELT, IA, JA, A, ISYM, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & RWORK, LENW, IWORK, LENIW ) ! ! * * * * * * DSDOMN * * * * * * ! !VD$ NOVECTOR call DUTERR( 'DSLUCS',IERR,KPRINT,nfail,LUN,ITER,ERR ) DO 30 NSAVE = 0, 3 if ( KPRINT >= 3 ) then write (LUN,1010) 'DSDOMN',ITOL, ISYM, NSAVE end if call DFILL( N, XITER, 0.0D0 ) call DSDOMN(N, F, XITER, NELT, IA, JA, A, & ISYM, NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, & IUNIT, RWORK, LENW, IWORK, LENIW ) call DUTERR( 'DSDOMN',IERR,KPRINT,nfail,LUN,ITER,ERR ) ! ! * * * * * * DSLUOM * * * * * * ! !VD$ NOVECTOR 30 continue DO 40 NSAVE=0,3 if ( KPRINT >= 3 ) then write (LUN,1010) 'DSLUOM',ITOL, ISYM, NSAVE end if call DFILL( N, XITER, 0.0D0 ) call DSLUOM(N, F, XITER, NELT, IA, JA, A, & ISYM, NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, & IUNIT, RWORK, LENW, IWORK, LENIW ) call DUTERR( 'DSLUOM',IERR,KPRINT,nfail,LUN,ITER,ERR ) ! ! * * * * * * DSDGMR * * * * * * ! !VD$ NOVECTOR 40 continue DO 50 NSAVE = 5, 12 if ( KPRINT >= 3 ) then write (LUN,1010) 'DSDGMR',ITOL, ISYM, NSAVE end if call DFILL( N, XITER, 0.0D0 ) ITOLGM = 0 call DSDGMR(N, F, XITER, NELT, IA, JA, A, & ISYM, NSAVE, ITOLGM, TOL, ITMAX, ITER, ERR, IERR, & IUNIT, RWORK, LENW, IWORK, LENIW ) call DUTERR( 'DSDGMR',IERR,KPRINT,nfail,LUN,ITER,ERR ) ! ! * * * * * * DSLUGM * * * * * * ! !VD$ NOVECTOR 50 continue DO 60 NSAVE = 5, 12 if ( KPRINT >= 3 ) then write (LUN,1010) 'DSLUGM',ITOL, ISYM, NSAVE end if call DFILL( N, XITER, 0.0D0 ) call DSLUGM(N, F, XITER, NELT, IA, JA, A, & ISYM, NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, & IUNIT, RWORK, LENW, IWORK, LENIW ) call DUTERR( 'DSLUGM',IERR,KPRINT,nfail,LUN,ITER,ERR ) 60 continue 70 continue 80 continue if ( nfail == 0 ) then ipass = 1 if ( kprint >= 2 ) write (LUN, 5001) else ipass = 0 if ( kprint >= 2 ) write (LUN, 5002) nfail end if return 990 FORMAT(/1X, 'DLAPQC -- Fatal error ', I1, ' generating ', & '*RANDOM* Matrix.') 1000 FORMAT(/1X,A6,' : ITOL = ',I2,' ISYM = ',I1) 1010 FORMAT(/1X,A6,' : ITOL = ',I2,' ISYM = ',I1,' NSAVE = ',I2) 1020 FORMAT(/' * RANDOM Matrix of size',I5,'*' & /' ', & 'Number of non-zeros & Density = ', I5,1P,D16.7) 1030 FORMAT(' Error tolerance = ',1P,D16.7) 1040 FORMAT(/' ***** SLAP Column Matrix *****'/ & ' Indx ia ja a'/(1X,I4,1X,I4,1X,I4,1X,1P,D16.7)) 1050 FORMAT('1'/' Running tests with N =',I3,', KASE =',I2, & ', ISYM =',I2) 5001 FORMAT('--------- All double precision SLAP tests passed ', & '---------') 5002 FORMAT('*********',I3,' double precision SLAP tests failed ', & '*********') end !! DLSEIT !***PURPOSE Quick check for DLSEI. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (LSEIQX-S, DLSEIT-D) !***KEYWORDS QUICK CHECK !***AUTHOR Hanson, R. J., (SNLA) ! Haskell, Karen, (SNLA) !***DESCRIPTION ! ! The sample problem solved is from a paper by J. Stoer, in ! SIAM Journal of Numerical Analysis, June 1971. ! !***ROUTINES CALLED d1mach, DAXPY, DCOPY, DDOT, DLSEI, DNRM2, DVOUT !***REVISION HISTORY (YYMMDD) ! 790216 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if, modified tolerances ! to use d1mach(4) rather than d1mach(3) and cleaned up ! FORMATs. (RWC) ! 920722 Initialized IP(1) and IP(2) for call to DLSEI. (BKS, WRB) ! 930214 Declarations sections added, code revised to test error ! returns for all values of kprint and code polished. (WRB) !***END PROLOGUE DDLSEIT ! .. Scalar Arguments .. subroutine DLSEIT (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN double precision CNORM, RELERR, RELNRM, RESNRM, RNORME, RNORML, & TNORM integer I, IDIGIT, JDIGIT, KONTRL, MA, MDD, ME, MEAP1, MEP1, MG, & MODE, N, NERR, NP1 ! .. Local Arrays .. LOGICAL FATAL double precision A(6,5), D(11,6), ERR(5), F(6), G(5,5), H(5), & PRGOPT(4), SOL(5), WORK(105), X(5) ! .. External Functions .. integer IP(17) double precision d1mach, DDOT, DNRM2 integer NUMXER ! .. External Subroutines .. EXTERNAL NUMXER, d1mach, DDOT, DNRM2 ! .. Intrinsic Functions .. EXTERNAL DAXPY, DCOPY, DLSEI, DVOUT, XGETF, XSETF ! .. Data statements .. ! ! Define the data arrays for the example. The array A contains ! the least squares equations. (There are no equality constraints ! in this example). ! INTRINSIC SQRT DATA A(1,1),A(1,2),A(1,3),A(1,4),A(1,5) & /-74.,80.,18.,-11.,-4./ DATA A(2,1),A(2,2),A(2,3),A(2,4),A(2,5) & /14.,-69.,21.,28.,0./ DATA A(3,1),A(3,2),A(3,3),A(3,4),A(3,5) & /66.,-72.,-5.,7.,1./ DATA A(4,1),A(4,2),A(4,3),A(4,4),A(4,5) & /-12.,66.,-30.,-23.,3./ DATA A(5,1),A(5,2),A(5,3),A(5,4),A(5,5) & /3.,8.,-7.,-4.,1./ DATA A(6,1),A(6,2),A(6,3),A(6,4),A(6,5) & ! ! The array G contains the inequality constraint equations, ! written in the sense ! (row vector)*(solution vector) >= (given value). ! /4.,-12.,4.,4.,0./ DATA G(1,1),G(1,2),G(1,3),G(1,4),G(1,5) & /-1.,-1.,-1.,-1.,-1./ DATA G(2,1),G(2,2),G(2,3),G(2,4),G(2,5) & /10.,10.,-3.,5.,4./ DATA G(3,1),G(3,2),G(3,3),G(3,4),G(3,5) & /-8.,1.,-2.,-5.,3./ DATA G(4,1),G(4,2),G(4,3),G(4,4),G(4,5) & /8.,-1.,2.,5.,-3./ DATA G(5,1),G(5,2),G(5,3),G(5,4),G(5,5) & ! ! Define the least squares right-side vector. ! /-4.,-2.,3.,-5.,1./ DATA F(1),F(2),F(3),F(4),F(5),F(6) & ! ! Define the inequality constraint right-side vector. ! /-5.,-9.,708.,4165.,-13266.,8409./ DATA H(1),H(2),H(3),H(4),H(5) & ! ! Define the vector that is the known solution. ! /-5.,20.,-40.,11.,-30./ DATA SOL(1),SOL(2),SOL(3),SOL(4),SOL(5) & !***FIRST EXECUTABLE STATEMENT DDLSEIT /1.,2.,-1.,3.,-4./ ! ! Define the matrix dimensions, number of least squares equations, ! number of equality constraints, total number of equations, and ! number of variables. Set ME=0 to indicate there are no equality ! constraints. ! if ( kprint >= 2) write (LUN, 9000) MDD = 11 MA = 6 MG = 5 N = 5 ME = 0 IP(1) = 105 IP(2) = 17 NP1 = N + 1 MEP1 = ME + 1 ! ! Copy the problem matrices. ! MEAP1 = ME + MA + 1 ! ! Copy the i-th column of the inequality constraint matrix into ! the work array. ! DO 10 I = 1, N ! ! Copy the i-th column of the least squares matrix into the work ! array. ! call DCOPY(MG, G(1,I), 1, D(MEAP1,I), 1) call DCOPY(MA, A(1,I), 1, D(MEP1,I), 1) ! ! Copy the right-side vectors into the work array in compatible ! order. ! 10 continue call DCOPY(MG, H, 1, D(MEAP1,NP1), 1) ! ! Use default program options in DLSEI, and set matrix-vector ! printing accuracy parameters. ! call DCOPY(MA, F, 1, D(MEP1,NP1), 1) PRGOPT(1) = 1 IDIGIT = -4 ! ! Compute residual norm of known least squares solution. ! (to be used to check computed residual norm = RNORML.) ! JDIGIT = -11 DO I = 1, MA WORK(I) = DDOT(N,D(I,1),MDD,SOL,1) - F(I) end do ! ! Call DLSEI to get solution in X(*), least squares residual in ! RNORML. ! RESNRM = DNRM2(MA,WORK,1) call DLSEI(D, MDD, ME, MA, MG, N, PRGOPT, X, RNORME, RNORML, MODE, & ! ! Compute relative error in problem variable solution and residual ! norm computation. ! WORK, IP) TNORM = DNRM2(N,SOL,1) call DCOPY(N, SOL, 1, ERR, 1) call DAXPY(N, -1.0D0, X, 1, ERR, 1) CNORM = DNRM2(N, ERR, 1) RELERR = CNORM/TNORM RELNRM = (RESNRM-RNORML)/RESNRM if ( RELERR <= 70.0D0*SQRT(d1mach(4)) .and. & RELNRM <= 5.0D0*d1mach(4) ) then ipass = 1 if ( kprint >= 3) write (LUN, 9010) else ipass = 0 if ( kprint >= 2) write (LUN, 9020) RELERR, RELNRM ! ! Print out known and computed solutions. ! end if if ( kprint >= 3 ) then call DVOUT(N, ERR, & '('' RESIDUALS FROM KNOWN LEAST SQUARES SOLUTION'')', & IDIGIT) call DVOUT(N, X, '(/'' SOLUTION COMPUTED BY DLSEI'')', JDIGIT) end if if ( kprint >= 2 ) then ! ! Print out the known and computed residual norms. ! if ( .NOT.(KPRINT == 2 .and. ipass /= 0) ) then call DVOUT(1, RESNRM, & '(/'' RESIDUAL NORM OF KNOWN LEAST SQUARES SOLUTION'')', & JDIGIT) call DVOUT(1, RNORML, & ! ! Print out the computed solution relative error. ! '(/'' RESIDUAL NORM COMPUTED BY DLSEI'')', JDIGIT) call DVOUT(1, RELERR, & ! ! Print out the computed relative error in residual norm. ! '(/'' COMPUTED SOLUTION RELATIVE ERROR'')', IDIGIT) call DVOUT(1, RELNRM, & '(/'' COMPUTED RELATIVE ERROR IN RESIDUAL NORM'')', IDIGIT) end if ! ! Check calls to error processor. ! 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, 9030) call DLSEI (D, 0, ME, MA, MG, N, PRGOPT, X, RNORME, RNORML, & MODE, WORK, IP) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr PRGOPT(1) = -1 call DLSEI (D, MDD, ME, MA, MG, N, PRGOPT, X, RNORME, RNORML, & MODE, WORK, IP) 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, 9040) end if else if ( kprint >= 3 ) then write (LUN, 9050) end if ! ! Print PASS/FAIL message. ! end if if ( ipass == 1 .and. KPRINT >= 2) write (LUN, 9100) if ( ipass == 0 .and. KPRINT >= 1) write (LUN, 9110) return 9000 FORMAT ('1TEST OF SUBROUTINE DLSEI') 9010 FORMAT (/' DLSEI PASSED TEST') 9020 FORMAT (/' DLSEI FAILED TEST'/' RELERR = ',1P,D20.6/' RELNRM = ', & D20.6) 9030 FORMAT (/ ' 2 ERROR MESSAGES EXPECTED') 9040 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 9050 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED') 9100 FORMAT (/' ****************DLSEI PASSED ALL TESTS***************') 9110 FORMAT (/' ****************DLSEI FAILED SOME TESTS**************') END subroutine DMAKE2 (TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, & !! DMAKE2 !***SUBSIDIARY !***PURPOSE Generate values for an M by N matrix A. !***LIBRARY SLATEC (BLAS) !***AUTHOR Du Croz, J. J., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! Generates values for an M by N matrix A within the bandwidth ! defined by KL and KU. ! Stores the values in the array AA in the data structure required ! by the routine, with unwanted elements set to rogue value. ! ! TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED DBEG !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DMAKE2 ! .. Parameters .. KU, RESET, TRANSL) double precision ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) double precision ROGUE ! .. Scalar Arguments .. PARAMETER ( ROGUE = -1.0D10 ) double precision TRANSL integer KL, KU, LDA, M, N, NMAX LOGICAL RESET CHARACTER*1 DIAG, UPLO ! .. Array Arguments .. CHARACTER*2 TYPE ! .. Local Scalars .. double precision A( NMAX, * ), AA( * ) integer I, I1, I2, I3, IBEG, IEND, IOFF, J, KK ! .. External Functions .. LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER double precision DBEG ! .. Intrinsic Functions .. EXTERNAL DBEG !***FIRST EXECUTABLE STATEMENT DMAKE2 INTRINSIC MAX, MIN GEN = TYPE( 1: 1 ) == 'G' SYM = TYPE( 1: 1 ) == 'S' TRI = TYPE( 1: 1 ) == 'T' UPPER = ( SYM.OR.TRI ) .and. UPLO == 'U' LOWER = ( SYM.OR.TRI ) .and. UPLO == 'L' ! ! Generate data in array A. ! UNIT = TRI .and. DIAG == 'U' DO 20 J = 1, N DO 10 I = 1, M if ( GEN.OR.( UPPER .and. I <= J ).OR.( LOWER.AND.I >= J ) ) & THEN if ( ( I <= J .and. J - I <= KU ).OR. & ( I >= J .and. I - J <= KL ) ) then A( I, J ) = DBEG( RESET ) + TRANSL else A( I, J ) = ZERO end if if ( I /= J ) then if ( SYM ) then A( J, I ) = A( I, J ) else if ( TRI ) then A( J, I ) = ZERO end if end if end if 10 continue if ( TRI ) then A( J, J ) = A( J, J ) + ONE end if if ( UNIT ) & A( J, J ) = ONE ! ! Store elements in array AS in data structure required by routine. ! 20 continue if ( TYPE == 'GE' ) then DO 50 J = 1, N DO 30 I = 1, M AA( I + ( J - 1 )*LDA ) = A( I, J ) 30 continue DO 40 I = M + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 40 continue 50 continue else if ( TYPE == 'GB' ) then DO 90 J = 1, N DO 60 I1 = 1, KU + 1 - J AA( I1 + ( J - 1 )*LDA ) = ROGUE 60 continue DO 70 I2 = I1, min ( KL + KU + 1, KU + 1 + M - J ) AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J ) 70 continue DO 80 I3 = I2, LDA AA( I3 + ( J - 1 )*LDA ) = ROGUE 80 continue 90 continue else if ( TYPE == 'SY'.OR.TYPE == 'TR' ) then DO 130 J = 1, N if ( UPPER ) then IBEG = 1 if ( UNIT ) then IEND = J - 1 else IEND = J end if else if ( UNIT ) then IBEG = J + 1 else IBEG = J end if IEND = N end if DO I = 1, IBEG - 1 AA( I + ( J - 1 )*LDA ) = ROGUE end do DO 110 I = IBEG, IEND AA( I + ( J - 1 )*LDA ) = A( I, J ) 110 continue DO 120 I = IEND + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 120 continue 130 continue else if ( TYPE == 'SB'.OR.TYPE == 'TB' ) then DO 170 J = 1, N if ( UPPER ) then KK = KL + 1 IBEG = max ( 1, KL + 2 - J ) if ( UNIT ) then IEND = KL else IEND = KL + 1 end if else KK = 1 if ( UNIT ) then IBEG = 2 else IBEG = 1 end if IEND = min ( KL + 1, 1 + M - J ) end if DO 140 I = 1, IBEG - 1 AA( I + ( J - 1 )*LDA ) = ROGUE 140 continue DO 150 I = IBEG, IEND AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J ) 150 continue DO I = IEND + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE end do 170 continue else if ( TYPE == 'SP'.OR.TYPE == 'TP' ) then IOFF = 0 DO 190 J = 1, N if ( UPPER ) then IBEG = 1 IEND = J else IBEG = J IEND = N end if DO 180 I = IBEG, IEND IOFF = IOFF + 1 AA( IOFF ) = A( I, J ) if ( I == J ) then if ( UNIT ) & AA( IOFF ) = ROGUE end if 180 continue 190 continue end if return END subroutine DMAKE3 (TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, & !! DMAKE3 !***SUBSIDIARY !***PURPOSE Generate values for an M by N matrix A. !***LIBRARY SLATEC (BLAS) !***AUTHOR Dongarra, J. J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) !***DESCRIPTION ! ! Generates values for an M by N matrix A within the bandwidth ! defined by KL and KU. ! Stores the values in the array AA in the data structure required ! by the routine, with unwanted elements set to rogue value. ! ! TYPE is 'GE', 'SY' or 'TR'. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED DBEG !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DMAKE3 ! .. Parameters .. RESET, TRANSL) double precision ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) double precision ROGUE ! .. Scalar Arguments .. PARAMETER ( ROGUE = -1.0D10 ) double precision TRANSL integer LDA, M, N, NMAX LOGICAL RESET CHARACTER*1 DIAG, UPLO ! .. Array Arguments .. CHARACTER*2 TYPE ! .. Local Scalars .. double precision A( NMAX, * ), AA( * ) integer I, IBEG, IEND, J ! .. External Functions .. LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER double precision DBEG ! .. Intrinsic Functions .. EXTERNAL DBEG !***FIRST EXECUTABLE STATEMENT DMAKE3 INTRINSIC MAX, MIN GEN = TYPE == 'GE' SYM = TYPE == 'SY' TRI = TYPE == 'TR' UPPER = ( SYM.OR.TRI ) .and. UPLO == 'U' LOWER = ( SYM.OR.TRI ) .and. UPLO == 'L' ! ! Generate data in array A. ! UNIT = TRI .and. DIAG == 'U' DO 20 J = 1, N DO 10 I = 1, M if ( GEN.OR.( UPPER .and. I <= J ).OR.( LOWER.AND.I >= J ) ) & THEN A( I, J ) = DBEG( RESET ) + TRANSL ! ! Set some elements to zero ! if ( I /= J ) then if ( N > 3 .and. J == N/2 ) & A( I, J ) = ZERO if ( SYM ) then A( J, I ) = A( I, J ) else if ( TRI ) then A( J, I ) = ZERO end if end if end if 10 continue if ( TRI ) & A( J, J ) = A( J, J ) + ONE if ( UNIT ) & A( J, J ) = ONE ! ! Store elements in array AS in data structure required by routine. ! 20 continue if ( TYPE == 'GE' ) then DO 50 J = 1, N DO 30 I = 1, M AA( I + ( J - 1 )*LDA ) = A( I, J ) 30 continue DO 40 I = M + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 40 continue 50 continue else if ( TYPE == 'SY'.OR.TYPE == 'TR' ) then DO 90 J = 1, N if ( UPPER ) then IBEG = 1 if ( UNIT ) then IEND = J - 1 else IEND = J end if else if ( UNIT ) then IBEG = J + 1 else IBEG = J end if IEND = N end if DO I = 1, IBEG - 1 AA( I + ( J - 1 )*LDA ) = ROGUE end do DO 70 I = IBEG, IEND AA( I + ( J - 1 )*LDA ) = A( I, J ) 70 continue DO 80 I = IEND + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 80 continue 90 continue end if return end subroutine DMMCH (TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, & !! DMMCH !***SUBSIDIARY !***PURPOSE Check the results of the computational tests. !***LIBRARY SLATEC (BLAS) !***AUTHOR Dongarra, J. J., (ANL) ! Duff, I., (AERE) ! Du Croz, J., (NAG) ! Hammarling, S., (NAG) !***DESCRIPTION ! ! Checks the results of the computational tests. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DMMCH ! .. Parameters .. BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FTL, NOUT, MV, KPRINT) double precision ZERO, ONE ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) LOGICAL FTL double precision ALPHA, BETA, EPS, ERR integer KK, KPRINT, LDA, LDB, LDC, LDCC, M, N, NOUT LOGICAL MV ! .. Array Arguments .. CHARACTER*1 TRANSA, TRANSB double precision A( LDA, * ), B( LDB, * ), C( LDC, * ), & ! .. Local Scalars .. CC( LDCC, * ), CT( * ), G( * ) double precision ERRI integer I, J, K ! .. Intrinsic Functions .. LOGICAL TRANA, TRANB !***FIRST EXECUTABLE STATEMENT DMMCH INTRINSIC ABS, MAX, SQRT TRANA = TRANSA == 'T'.OR.TRANSA == 'C' ! ! Compute expected result, one column at a time, in CT using data ! in A, B and C. ! Compute gauges in G. ! TRANB = TRANSB == 'T'.OR.TRANSB == 'C' ! DO 120 J = 1, N DO 10 I = 1, M CT( I ) = ZERO G( I ) = ZERO 10 continue if ( .NOT.TRANA .and. .NOT.TRANB ) then DO 30 K = 1, KK DO 20 I = 1, M CT( I ) = CT( I ) + A( I, K )*B( K, J ) G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) ) 20 continue 30 continue else if ( TRANA .and. .NOT.TRANB ) then DO 50 K = 1, KK DO 40 I = 1, M CT( I ) = CT( I ) + A( K, I )*B( K, J ) G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) ) 40 continue 50 continue else if ( .NOT.TRANA .and. TRANB ) then DO 70 K = 1, KK DO 60 I = 1, M CT( I ) = CT( I ) + A( I, K )*B( J, K ) G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) ) 60 continue 70 continue else if ( TRANA .and. TRANB ) then DO K = 1, KK DO I = 1, M CT( I ) = CT( I ) + A( K, I )*B( J, K ) G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) ) end do end do end if DO 100 I = 1, M CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) ) ! ! Compute the error ratio for this result. ! 100 continue ERR = ZERO DO 110 I = 1, M ERRI = ABS( CT( I ) - CC( I, J ) )/EPS if ( G( I ) /= ZERO ) & ERRI = ERRI/G( I ) ERR = max ( ERR, ERRI ) if ( ERR*SQRT( EPS ) >= ONE ) then FTL = .TRUE. if ( kprint >= 2 ) then write ( NOUT, FMT = 9999 ) DO 140 K = 1, M if ( MV ) then write ( NOUT, FMT = 9998 )K, CT( K ), CC( K, J ) else write ( NOUT, FMT = 9998 )K, CC( K, J ), CT( K ) end if 140 continue end if end if 110 continue 120 continue return 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', & 'F ACCURATE *******', /' EXPECTED RESULT COMPU', & 'TED RESULT' ) 9998 FORMAT( 1X, I7, 2G18.6 ) end subroutine DMVCH (TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, & !! DMVCH !***SUBSIDIARY !***PURPOSE Check the results of the computational tests. !***LIBRARY SLATEC (BLAS) !***AUTHOR Du Croz, J. J., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! Checks the results of the computational tests. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE DMVCH ! .. Parameters .. INCY, YT, G, YY, EPS, ERR, FTL, NOUT, MV, KPRINT) double precision ZERO, ONE ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) double precision ALPHA, BETA, EPS, ERR integer INCX, INCY, KPRINT, M, N, NMAX, NOUT LOGICAL MV, FTL ! .. Array Arguments .. CHARACTER*1 TRANS double precision A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ), & ! .. Local Scalars .. YY( * ) double precision ERRI integer I, INCXL, INCYL, IY, J, JX, K, KX, KY, ML, NL ! .. Intrinsic Functions .. LOGICAL TRAN !***FIRST EXECUTABLE STATEMENT DMVCH INTRINSIC ABS, MAX, SQRT TRAN = TRANS == 'T'.OR.TRANS == 'C' if ( TRAN ) then ML = N NL = M else ML = M NL = N end if if ( INCX < 0 ) then KX = NL INCXL = -1 else KX = 1 INCXL = 1 end if if ( INCY < 0 ) then KY = ML INCYL = -1 else KY = 1 INCYL = 1 ! ! Compute expected result in YT using data in A, X and Y. ! Compute gauges in G. ! end if IY = KY DO 30 I = 1, ML YT( IY ) = ZERO G( IY ) = ZERO JX = KX if ( TRAN ) then DO 10 J = 1, NL YT( IY ) = YT( IY ) + A( J, I )*X( JX ) G( IY ) = G( IY ) + ABS( A( J, I )*X( JX ) ) JX = JX + INCXL 10 continue else DO J = 1, NL YT( IY ) = YT( IY ) + A( I, J )*X( JX ) G( IY ) = G( IY ) + ABS( A( I, J )*X( JX ) ) JX = JX + INCXL end do end if YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY ) G( IY ) = ABS( ALPHA )*G( IY ) + ABS( BETA*Y( IY ) ) IY = IY + INCYL ! ! Compute the error ratio for this result. ! 30 continue ERR = ZERO DO 40 I = 1, ML ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS if ( G( I ) /= ZERO ) & ERRI = ERRI/G( I ) ERR = max ( ERR, ERRI ) if ( ERR*SQRT( EPS ) >= ONE ) then FTL = .TRUE. if ( kprint >= 2 ) then write ( NOUT, FMT = 9999 ) DO K = 1, ML if ( MV ) then write ( NOUT, FMT = 9998 )K, YT( K ), & YY( 1 + ( K - 1 )*ABS( INCY ) ) else write ( NOUT, FMT = 9998 )K, & YY( 1 + ( K - 1 )*ABS( INCY ) ), YT( K ) end if end do end if end if 40 continue return 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', & 'F ACCURATE *******', /' EXPECTED RESULT COMPU', & 'TED RESULT' ) ! ! End of DMVCH. ! 9998 FORMAT( 1X, I7, 2G18.6 ) end !! DNLS1Q !***PURPOSE Quick check for DNLS1E, DNLS1 and DCOV. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SNLS1Q-S, DNLS1Q-D) !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine performs a quick check on the subroutines DNLS1E ! (and DNLS1) and DCOV. ! !***ROUTINES CALLED DENORM, DFCN1, DFCN2, DFCN3, DFDJC3, PASS, d1mach, ! DCOV, DNLS1E !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 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 DNLS1Q ! .. Scalar Arguments .. subroutine DNLS1Q (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN double precision FNORM, FNORMS, ONE, SIGMA, TEMP1, TEMP2, TEMP3, & TOL, TOL2, ZERO integer I, IFLAG, INFO, INFOS, IOPT, KONTRL, LDFJAC, LWA, M, N, & NERR, NPRINT ! .. Local Arrays .. LOGICAL FATAL double precision FJAC(10,2), FJROW(2), FJTJ(3), FVEC(10), WA(40), & X(2) ! .. External Functions .. integer IW(2) double precision d1mach, DENORM integer NUMXER ! .. External Subroutines .. EXTERNAL d1mach, DENORM, NUMXER EXTERNAL DFCN1, DFCN2, DFCN3, DFDJC3, PASS, DCOV, DNLS1E, XGETF, & ! .. Intrinsic Functions .. XSETF !***FIRST EXECUTABLE STATEMENT DNLS1Q INTRINSIC ABS, SQRT ! if ( kprint >= 2) write (LUN,9000) ipass = 1 INFOS = 1 FNORMS = 1.1151779D+01 M = 10 N = 2 LWA = 40 LDFJAC = 10 NPRINT = -1 IFLAG = 1 ZERO = 0.0D0 ONE = 1.0D0 TOL = max ( SQRT(40.0D0*d1mach(4)),1.0D-12) ! ! OPTION=2, the full Jacobian is stored and the user provides the ! Jacobian. ! TOL2 = SQRT(TOL) IOPT = 2 X(1) = 3.0D-1 X(2) = 4.0D-1 call DNLS1E(DFCN2,IOPT,M,N,X,FVEC,TOL,NPRINT,INFO,IW,WA,LWA) FNORM = DENORM(M,FVEC) if ( INFO == INFOS .and. ABS(FNORM-FNORMS)/FNORMS <= TOL2 ) then FATAL = .FALSE. if ( kprint >= 3) call PASS(LUN,1,1) else ipass = 0 FATAL = .TRUE. if ( kprint >= 2) call PASS(LUN,1,0) end if if ( (FATAL .and. KPRINT >= 2) .OR. KPRINT>=3) & ! ! Form JAC-transpose*JAC. ! write (LUN,9010) INFOS,FNORMS,INFO,FNORM SIGMA = FNORM*FNORM/(M-N) IFLAG = 2 call DFCN2(IFLAG,M,N,X,FVEC,FJAC,LDFJAC) DO 20 I = 1,3 FJTJ(I) = ZERO 20 continue DO 30 I = 1,M FJTJ(1) = FJTJ(1) + FJAC(I,1)**2 FJTJ(2) = FJTJ(2) + FJAC(I,1)*FJAC(I,2) FJTJ(3) = FJTJ(3) + FJAC(I,2)**2 ! ! Calculate the covariance matrix. ! 30 continue call DCOV(DFCN2,IOPT,M,N,X,FVEC,FJAC,LDFJAC,INFO,WA(1),WA(N+1), & ! ! Form JAC-transpose*JAC * covariance matrix (should = SIGMA*I). ! WA(2*N+1),WA(3*N+1)) TEMP1 = (FJTJ(1)*FJAC(1,1)+FJTJ(2)*FJAC(1,2))/SIGMA TEMP2 = (FJTJ(1)*FJAC(1,2)+FJTJ(2)*FJAC(2,2))/SIGMA TEMP3 = (FJTJ(2)*FJAC(1,2)+FJTJ(3)*FJAC(2,2))/SIGMA if ( INFO == INFOS .and. ABS(TEMP1-ONE) < TOL2 .AND. & ABS(TEMP2) < TOL2 .and. ABS(TEMP3-ONE) < TOL2 ) then FATAL = .FALSE. if ( kprint >= 3) call PASS(LUN,2,1) else ipass = 0 FATAL = .TRUE. if ( kprint >= 2) call PASS(LUN,2,0) end if if ( (FATAL .and. KPRINT >= 2) .OR. KPRINT>=3) & ! ! OPTION=1, the full Jacobian is stored and the code approximates ! the Jacobian. ! write (LUN,9020) INFOS,INFO,TEMP1,TEMP2,TEMP3 IOPT = 1 X(1) = 3.0D-1 X(2) = 4.0D-1 call DNLS1E(DFCN1,IOPT,M,N,X,FVEC,TOL,NPRINT,INFO,IW,WA,LWA) FNORM = DENORM(M,FVEC) if ( INFO == INFOS .and. ABS(FNORM-FNORMS)/FNORMS <= TOL2 ) then FATAL = .FALSE. if ( kprint >= 3) call PASS(LUN,3,1) else ipass = 0 FATAL = .TRUE. if ( kprint >= 2) call PASS(LUN,3,0) end if if ( (FATAL .and. KPRINT >= 2) .OR. KPRINT>=3) & ! ! Form JAC-transpose*JAC. ! write (LUN,9010) INFOS,FNORMS,INFO,FNORM SIGMA = FNORM*FNORM/(M-N) IFLAG = 1 call DFDJC3(DFCN1,M,N,X,FVEC,FJAC,LDFJAC,IFLAG,ZERO,WA) DO 60 I = 1,3 FJTJ(I) = ZERO 60 continue DO 70 I = 1,M FJTJ(1) = FJTJ(1) + FJAC(I,1)**2 FJTJ(2) = FJTJ(2) + FJAC(I,1)*FJAC(I,2) FJTJ(3) = FJTJ(3) + FJAC(I,2)**2 ! ! Calculate the covariance matrix. ! 70 continue call DCOV(DFCN1,IOPT,M,N,X,FVEC,FJAC,LDFJAC,INFO,WA(1),WA(N+1), & ! ! Form JAC-transpose*JAC * covariance matrix (should = SIGMA*I). ! WA(2*N+1),WA(3*N+1)) TEMP1 = (FJTJ(1)*FJAC(1,1)+FJTJ(2)*FJAC(1,2))/SIGMA TEMP2 = (FJTJ(1)*FJAC(1,2)+FJTJ(2)*FJAC(2,2))/SIGMA TEMP3 = (FJTJ(2)*FJAC(1,2)+FJTJ(3)*FJAC(2,2))/SIGMA if ( INFO == INFOS .and. ABS(TEMP1-ONE) < TOL2 .AND. & ABS(TEMP2) < TOL2 .and. ABS(TEMP3-ONE) < TOL2 ) then FATAL = .FALSE. if ( kprint >= 3) call PASS(LUN,4,1) else ipass = 0 FATAL = .TRUE. if ( kprint >= 2) call PASS(LUN,4,0) end if if ( (FATAL .and. KPRINT >= 2) .OR. KPRINT>=3) & ! ! OPTION=3, the full Jacobian is not stored. Only the product of ! the Jacobian transpose and Jacobian is stored. The user provides ! the Jacobian one row at a time. ! write (LUN,9020) INFOS,INFO,TEMP1,TEMP2,TEMP3 IOPT = 3 X(1) = 3.0D-1 X(2) = 4.0D-1 call DNLS1E(DFCN3,IOPT,M,N,X,FVEC,TOL,NPRINT,INFO,IW,WA,LWA) FNORM = DENORM(M,FVEC) if ( INFO == INFOS .and. ABS(FNORM-FNORMS)/FNORMS <= TOL2 ) then FATAL = .FALSE. if ( kprint >= 3) call PASS(LUN,5,1) else ipass = 0 FATAL = .TRUE. if ( kprint >= 2) call PASS(LUN,5,0) end if if ( (FATAL .and. KPRINT >= 2) .OR. KPRINT>=3) & ! ! Form JAC-transpose*JAC. ! write (LUN,9010) INFOS,FNORMS,INFO,FNORM SIGMA = FNORM*FNORM/(M-N) FJTJ(1:3) = ZERO IFLAG = 3 DO 110 I = 1,M call DFCN3(IFLAG,M,N,X,FVEC,FJROW,I) FJTJ(1) = FJTJ(1) + FJROW(1)**2 FJTJ(2) = FJTJ(2) + FJROW(1)*FJROW(2) FJTJ(3) = FJTJ(3) + FJROW(2)**2 ! ! Calculate the covariance matrix. ! 110 continue call DCOV(DFCN3,IOPT,M,N,X,FVEC,FJAC,LDFJAC,INFO,WA(1),WA(N+1), & ! ! Form JAC-transpose*JAC * covariance matrix (should = SIGMA*I). ! WA(2*N+1),WA(3*N+1)) TEMP1 = (FJTJ(1)*FJAC(1,1)+FJTJ(2)*FJAC(1,2))/SIGMA TEMP2 = (FJTJ(1)*FJAC(1,2)+FJTJ(2)*FJAC(2,2))/SIGMA TEMP3 = (FJTJ(2)*FJAC(1,2)+FJTJ(3)*FJAC(2,2))/SIGMA if ( INFO == INFOS .and. ABS(TEMP1-ONE) < TOL2 .AND. & ABS(TEMP2) < TOL2 .and. ABS(TEMP3-ONE) < TOL2 ) then FATAL = .FALSE. if ( kprint >= 3) call PASS(LUN,6,1) else ipass = 0 FATAL = .TRUE. if ( kprint >= 2) call PASS(LUN,6,0) end if if ( (FATAL .and. KPRINT >= 2) .OR. KPRINT>=3) & ! ! Test improper input parameters. ! write (LUN,9020) INFOS,INFO,TEMP1,TEMP2,TEMP3 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, 9060) LWA = 35 IOPT = 2 X(1) = 3.0D-1 X(2) = 4.0D-1 call DNLS1E(DFCN2,IOPT,M,N,X,FVEC,TOL,NPRINT,INFO,IW,WA,LWA) ! if ( INFO /= 0 .OR. NUMXER(NERR) /= 2) FATAL = .TRUE. M = 0 call DCOV(DFCN2,IOPT,M,N,X,FVEC,FJAC,LDFJAC,INFO,WA(1),WA(N+1), & WA(2*N+1),WA(3*N+1)) ! ! Restore KONTRL and check to see if the tests of error detection ! passed. ! if ( INFO /= 0 .OR. NUMXER(NERR) /= 2) FATAL = .TRUE. call XSETF (KONTRL) if ( FATAL ) then ipass = 0 if ( kprint >= 2 ) then write (LUN, 9070) end if else if ( kprint >= 3 ) then write (LUN, 9080) end if ! ! Print PASS/FAIL message. ! end if if ( ipass == 1 .and. KPRINT >= 2) write (LUN,9100) ! if ( ipass == 0 .and. KPRINT >= 1) write (LUN,9110) ! 130 RETURN 9000 FORMAT ('1' / ' Test DNLS1E, DNLS1 and DCOV') 9010 FORMAT (' EXPECTED VALUE OF INFO AND RESIDUAL NORM', I5, D20.9 / & ' RETURNED VALUE OF INFO AND RESIDUAL NORM', I5, D20.9 /) 9020 FORMAT (' EXPECTED AND RETURNED VALUE OF INFO', I5, 10X, I5 / & ' RETURNED PRODUCT OF (J-TRANS*J)*COVARIANCE MATRIX/SIGMA' & / ' (SHOULD = THE IDENTITY -- 1.0, 0.0, 1.0)' / 3D20.9 /) 9060 FORMAT (/ ' TRIGGER 2 ERROR MESSAGES',/) 9070 FORMAT (' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 9080 FORMAT (' ALL INCORRECT ARGUMENT TESTS PASSED') 9100 FORMAT (/' *************DNLS1E PASSED ALL TESTS*****************') 9110 FORMAT (/' ************DNLS1E FAILED SOME TESTS*****************') end !! DNSQQK !***PURPOSE Quick check for DNSQE and DNSQ. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SNSQQK-S, DNSQQK-D) !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine performs a quick check on the subroutine DNSQE ! (and DNSQ). ! !***ROUTINES CALLED d1mach, DENORM, DNSQE, DQFCN2, DQJAC2, PASS !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920310 Code cleaned up and TYPE section added. (RWC, WRB) !***END PROLOGUE DNSQQK ! .. Scalar Arguments .. subroutine DNSQQK (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN double precision FNORM, FNORMS, TOL ! .. Local Arrays .. integer ICNT, INFO, INFOS, IOPT, LWA, N, NPRINT double precision FVEC(2), WA(19), X(2) ! .. External Functions .. integer ITEST(3) double precision d1mach, DENORM ! .. External Subroutines .. EXTERNAL d1mach, DENORM ! .. Intrinsic Functions .. EXTERNAL DNSQE, DQFCN2, DQJAC2, PASS !***FIRST EXECUTABLE STATEMENT DNSQQK INTRINSIC SQRT INFOS = 1 FNORMS = 0.0D0 N = 2 LWA = 19 NPRINT = -1 TOL = SQRT(d1mach(4)) ! ! Option 1, the user provides the Jacobian. ! if ( kprint >= 2) write (LUN,9000) IOPT = 1 X(1) = -1.2D0 X(2) = 1.0D0 call DNSQE (DQFCN2,DQJAC2,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA) ICNT = 1 FNORM = DENORM(N,FVEC) ITEST(ICNT) = 0 ! if ( (INFO == INFOS) .and. (FNORM-FNORMS <= TOL)) ITEST(ICNT) = 1 if ( kprint /= 0 ) then if ( (KPRINT >= 2 .and. ITEST(ICNT) /= 1) .OR. KPRINT>=3) & write (LUN,9010) INFOS,FNORMS,INFO,FNORM if ( (KPRINT >= 2) .OR. (KPRINT == 1 .and. ITEST(ICNT) /= 1)) & call PASS (LUN, ICNT, ITEST(ICNT)) ! ! Option 2, the code approximates the Jacobian. ! end if IOPT = 2 X(1) = -1.2D0 X(2) = 1.0D0 call DNSQE (DQFCN2,DQJAC2,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA) ICNT = 2 FNORM = DENORM(N,FVEC) ITEST(ICNT) = 0 ! if ( (INFO == INFOS) .and. (FNORM-FNORMS <= TOL)) ITEST(ICNT) = 1 if ( kprint /= 0 ) then if ( KPRINT >= 3 .OR. (KPRINT>=2 .and. ITEST(ICNT) /= 1)) & write (LUN,9010) INFOS, FNORMS, INFO, FNORM if ( KPRINT >= 2 .OR. (KPRINT == 1 .and. ITEST(ICNT) /= 1)) & call PASS (LUN, ICNT, ITEST(ICNT)) ! ! Test improper input parameters. ! end if LWA = 15 IOPT = 1 X(1) = -1.2D0 X(2) = 1.0D0 call DNSQE (DQFCN2,DQJAC2,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA) ICNT = 3 ITEST(ICNT) = 0 if ( INFO == 0) ITEST(ICNT) = 1 if ( KPRINT >= 2 .OR. (KPRINT == 1 .and. ITEST(ICNT) /= 1)) & ! ! Set IPASS. ! call PASS (LUN, ICNT, ITEST(ICNT)) ipass = ITEST(1)*ITEST(2)*ITEST(3) if ( KPRINT >= 1 .and. ipass /= 1) write (LUN,9020) if ( KPRINT >= 2 .and. ipass == 1) write (LUN,9030) return 9000 FORMAT ('1' / ' DNSQE QUICK CHECK'/) 9010 FORMAT (' EXPECTED VALUE OF INFO AND RESIDUAL NORM', I5, D20.5 / & ' RETURNED VALUE OF INFO AND RESIDUAL NORM', I5, D20.5 /) 9020 FORMAT (/' **********WARNING -- DNSQE/DNSQ FAILED SOME TESTS****', & '******') 9030 FORMAT (/' ----------DNSQE/DNSQ PASSED ALL TESTS----------') end !! DPCHQ1 !***PURPOSE Test the PCHIP evaluators DCHFDV, DCHFEV, DPCHFD, DPCHFE. !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (PCHQK1-S, DPCHQ1-D) !***KEYWORDS PCHIP EVALUATOR QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! DPCHIP QUICK CHECK NUMBER 1 ! ! TESTS THE EVALUATORS: DCHFDV, DCHFEV, DPCHFD, DPCHFE. ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call DPCHQ1 (LUN, KPRINT, IPASS) ! ! *Arguments: ! ! LUN :IN is the unit number to which output is to be written. ! ! KPRINT:IN controls the amount of output, as specified in the ! SLATEC Guidelines. ! ! IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. ! IPASS=0 indicates one or more tests failed. ! ! *Description: ! ! This routine carries out three tests of the PCH evaluators: ! DEVCHK tests the single-cubic evaluators. ! DEVPCK tests the full PCH evaluators. ! DEVERK exercises the error returns in all evaluators. ! !***ROUTINES CALLED DEVCHK, DEVERK, DEVPCK !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890306 Changed ipass to the more accurate name IFAIL. (FNF) ! 890307 Removed conditional on call to DEVERK. ! 890706 Cosmetic changes to prologue. (WRB) ! 891004 Correction in prologue. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900309 Added DEVERK to list of routines called. (FNF) ! 900314 Improved some output formats. ! 900315 Revised prologue and improved some output formats. (FNF) ! 900316 Additional minor cosmetic changes. (FNF) ! 900321 Removed IFAIL from call sequence for SLATEC standards and ! made miscellaneous cosmetic changes. (FNF) ! 930317 Improved output formats. (FNF) !***END PROLOGUE DPCHQ1 ! ! Declare arguments. ! subroutine DPCHQ1 (LUN, KPRINT, IPASS) ! ! DECLARE LOCAL VARIABLES. ! integer LUN, KPRINT, IPASS integer I1, I2, I3, I4, I5, I6, I7, I8, I9, IFAIL, NPTS double precision WORK (4000) ! !***FIRST EXECUTABLE STATEMENT DPCHQ1 LOGICAL FAIL ! ! TEST DCHFDV AND DCHFEV. ! if ( kprint >= 2) write (LUN, 1000) KPRINT IFAIL = 0 NPTS = 1000 I1 = 1 + NPTS I2 = I1 + NPTS I3 = I2 + NPTS call DEVCHK (LUN, KPRINT, NPTS, WORK(1), WORK(I1), WORK(I2), & WORK(I3), FAIL) ! ! TEST DPCHFD AND DPCHFE. ! if ( FAIL) IFAIL = IFAIL + 1 I1 = 1 + 10 I2 = I1 + 10 I3 = I2 + 100 I4 = I3 + 100 I5 = I4 + 100 I6 = I5 + 51 I7 = I6 + 51 I8 = I7 + 51 I9 = I8 + 51 call DEVPCK (LUN, KPRINT, WORK(1), WORK(I1), WORK(I2), WORK(I3), & WORK(I4), WORK(I5), WORK(I6), WORK(I7), WORK(I8), & WORK(I9), FAIL) ! ! TEST ERROR RETURNS. ! if ( FAIL) IFAIL = IFAIL + 2 call DEVERK (LUN, KPRINT, FAIL) ! ! PRINT SUMMARY AND TERMINATE. ! At this point, IFAIL has the following value: ! IFAIL = 0 IF ALL TESTS PASSED. ! IFAIL BETWEEN 1 AND 7 IS THE SUM OF: ! IFAIL=1 IF SINGLE CUBIC TEST FAILED. (SEE DEVCHK OUTPUT.) ! IFAIL=2 IF DPCHFD/DPCHFE TEST FAILED. (SEE DEVPCK OUTPUT.) ! IFAIL=4 IF ERROR RETURN TEST FAILED. (SEE DEVERK OUTPUT.) ! if ( FAIL) IFAIL = IFAIL + 4 ! if ( (KPRINT >= 2) .and. (IFAIL /= 0)) write (LUN, 3001) IFAIL if ( IFAIL == 0) THEN ipass = 1 if ( KPRINT >= 2) WRITE(LUN,99998) else ipass = 0 if ( KPRINT >= 1) WRITE(LUN,99999) ! end if ! ! FORMATS. ! return 1000 FORMAT ('1'/' ------------ DPCHIP QUICK CHECK OUTPUT', & ' ------------' //20X,'( kprint =',I2,' )') 3001 FORMAT (/' *** TROUBLE ***',I5,' EVALUATION TESTS FAILED.') 99998 FORMAT (/' ------------ DPCHIP PASSED ALL EVALUATION TESTS', & ' ------------') 99999 FORMAT (/' ************ DPCHIP FAILED SOME EVALUATION TESTS', & ! -------- LAST LINE OF DPCHQ1 FOLLOWS ----------------------------- ' ************') end !! DPCHQ2 !***PURPOSE Test the PCHIP integrators DPCHIA and DPCHID. !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (PCHQK2-S, DPCHQ2-D) !***KEYWORDS PCHIP INTEGRATOR QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! DPCHIP QUICK CHECK NUMBER 2 ! ! TESTS THE INTEGRATORS: DPCHIA, DPCHID. ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call DPCHQ2 (LUN, KPRINT, IPASS) ! ! *Arguments: ! ! LUN :IN is the unit number to which output is to be written. ! ! KPRINT:IN controls the amount of output, as specified in the ! SLATEC Guidelines. ! ! IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. ! IPASS=0 indicates one or more tests failed. ! ! *Description: ! ! This routine constructs data from a cubic, integrates it with DPCHIA ! and compares the results with the correct answer. ! Since DPCHIA calls DPCHID, this tests both integrators. ! !***ROUTINES CALLED d1mach, DPCHIA !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890306 Changed ipass to the more accurate name IFAIL. (FNF) ! 890316 1. Removed IMPLICIT statement. (FNF) ! 2. Eliminated unnecessary variable N1. (FNF) ! 3. Miscellaneous cosmetic changes. (FNF) ! 891004 Cosmetic changes to prologue. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900314 Improved some output formats. (FNF) ! 900315 Revised prologue and improved some output formats. (FNF) ! 900316 Additional minor cosmetic changes. (FNF) ! 900321 Removed IFAIL from call sequence for SLATEC standards and ! made miscellaneous cosmetic changes. (FNF) ! 900323 Corrected list of routines called. (FNF) ! 901130 Added 1P's to formats; changed to allow KPRINT.gt.3. (FNF) ! 910708 Minor modifications in use of KPRINT. (WRB) ! 930317 Improved output formats. (FNF) !***END PROLOGUE DPCHQ2 ! ! Declare arguments. ! subroutine DPCHQ2 (LUN, KPRINT, IPASS) ! ! DECLARE VARIABLES. ! integer LUN, KPRINT, IPASS integer I, IEREXP(17), IERR, IFAIL, N, NPAIRS double precision & A(17), B(17), CALC, D(7), ERRMAX, ERROR, F(7), MACHEP, & ONE, THREE, THRQTR, TOL, TRUE, TWO, X(7) ! ! DECLARE EXTERNALS. ! LOGICAL FAIL, SKIP ! ! DEFINE TEST FUNCTIONS. ! double precision DPCHIA, d1mach double precision AX, FCN, DERIV, ANTDER FCN(AX) = THREE*AX*AX*(AX-TWO) DERIV(AX) = THREE*AX*(TWO*(AX-TWO) + AX) ! ! INITIALIZE. ! ANTDER(AX) = AX**3 * (THRQTR*AX - TWO) DATA THRQTR /0.75D0/, ONE /1.D0/, TWO /2.D0/, THREE /3.D0/ DATA N /7/ DATA X /-4.D0, -2.D0, -0.9D0, 0.D0, 0.9D0, 2.D0, 4.D0/ DATA NPAIRS /17/ DATA A /-3.0D0, 3.0D0,-0.5D0,-0.5D0,-0.5D0,-4.0D0,-4.0D0, 3.0D0, & -5.0D0,-5.0D0,-6.0D0, 6.0D0,-1.5D0,-1.5D0,-3.0D0, 3.0D0, 0.5D0/ DATA B / 3.0D0,-3.0D0, 1.0D0, 2.0D0, 5.0D0,-0.5D0, 4.0D0, 5.0D0, & -3.0D0, 5.0D0,-5.0D0, 5.0D0,-0.5D0,-1.0D0,-2.5D0, 3.5D0, 0.5D0/ ! ! SET PASS/FAIL TOLERANCE. ! !***FIRST EXECUTABLE STATEMENT DPCHQ2 DATA IEREXP /0,0,0,0,2,0,0,2,1,3,3,3,0,0,0,0,0/ MACHEP = d1mach(4) ! ! SET UP PCH FUNCTION DEFINITION. ! TOL = 100.D0*MACHEP DO 10 I = 1, N F(I) = FCN(X(I)) D(I) = DERIV(X(I)) ! 10 continue if ( kprint >= 3) write (LUN, 1000) if ( kprint >= 2) write (LUN, 1001) ! ! LOOP OVER (A,B)-PAIRS. ! if ( kprint >= 3) write (LUN, 1002) (X(I), F(I), D(I), I=1,N) ! if ( kprint >= 3) write (LUN, 2000) ! IFAIL = 0 SKIP = .FALSE. ! --------------------------------------------- DO 20 I = 1, NPAIRS ! --------------------------------------------- CALC = DPCHIA (N, X, F, D, 1, SKIP, A(I), B(I), IERR) if ( IERR >= 0) THEN FAIL = IERR /= IEREXP(I) TRUE = ANTDER(B(I)) - ANTDER(A(I)) ERROR = CALC - TRUE if ( kprint >= 3) THEN if ( FAIL) THEN write (LUN, 2001) A(I), B(I), IERR, TRUE, CALC, ERROR, & IEREXP(I) else write (LUN, 2002) A(I), B(I), IERR, TRUE, CALC, ERROR end if ! end if ERROR = ABS(ERROR) / max ( ONE, ABS(TRUE)) if ( FAIL .OR. (ERROR > TOL)) IFAIL = IFAIL + 1 if ( I == 1) THEN ERRMAX = ERROR else ERRMAX = max ( ERRMAX, ERROR) end if else if ( kprint >= 3) write (LUN, 2002) A(I), B(I), IERR IFAIL = IFAIL + 1 end if ! ! PRINT SUMMARY. ! 20 continue if ( kprint >= 2) THEN write (LUN, 2003) ERRMAX, TOL if ( IFAIL /= 0) write (LUN, 3001) IFAIL ! ! TERMINATE. ! end if if ( IFAIL == 0) THEN ipass = 1 if ( KPRINT >= 2) WRITE(LUN,99998) else ipass = 0 if ( KPRINT >= 1) WRITE(LUN,99999) ! end if ! ! FORMATS. ! return 1000 FORMAT ('1'//10X,'TEST DPCHIP INTEGRATORS') 1001 FORMAT (//10X,'DPCHQ2 RESULTS'/10X,'--------------') 1002 FORMAT (// 5X,'DATA:' //11X,'X',9X,'F',9X,'D' /(5X,3F10.3) ) 2000 FORMAT (// 5X,'TEST RESULTS:' & //' A B ERR TRUE',16X,'CALC',15X,'ERROR') 2001 FORMAT (2F6.1,I5,1P,2D20.10,D15.5,' (',I1,') *****' ) 2002 FORMAT (2F6.1,I5,1P,2D20.10,D15.5) 2003 FORMAT (/' MAXIMUM RELATIVE ERROR IS:',1P,D15.5, & ', TOLERANCE:',1P,D15.5) 3001 FORMAT (/' *** TROUBLE ***',I5,' INTEGRATION TESTS FAILED.') 99998 FORMAT (/' ------------ DPCHIP PASSED ALL INTEGRATION TESTS', & ' ------------') 99999 FORMAT (/' ************ DPCHIP FAILED SOME INTEGRATION TESTS', & ! -------- LAST LINE OF DPCHQ2 FOLLOWS ----------------------------- ' ************') end !! DPCHQ3 !***PURPOSE Test the PCHIP interpolators DPCHIC, DPCHIM, DPCHSP. !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (PCHQK3-S, DPCHQ3-D) !***KEYWORDS PCHIP INTERPOLATOR QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! DPCHIP QUICK CHECK NUMBER 3 ! ! TESTS THE INTERPOLATORS: DPCHIC, DPCHIM, DPCHSP. ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call DPCHQ3 (LUN, KPRINT, IPASS) ! ! *Arguments: ! ! LUN :IN is the unit number to which output is to be written. ! ! KPRINT:IN controls the amount of output, as specified in the ! SLATEC Guidelines. ! ! IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. ! IPASS=0 indicates one or more tests failed. ! ! *Description: ! ! This routine interpolates a constructed data set with all three ! DPCHIP interpolators and compares the results with those obtained ! on a Cray X/MP. Two different values of the DPCHIC parameter SWITCH ! are used. ! ! *Remarks: ! 1. The Cray results are given only to nine significant figures, ! so don't expect them to match to more. ! 2. The results will depend to some extent on the accuracy of ! the EXP function. ! !***ROUTINES CALLED COMP, d1mach, DPCHIC, DPCHIM, DPCHSP !***REVISION HISTORY (YYMMDD) ! 900309 DATE WRITTEN ! 900314 Converted to a subroutine and added a SLATEC 4.0 prologue. ! 900315 Revised prologue and improved some output formats. (FNF) ! 900316 Made TOLD machine-dependent and added extra output when ! KPRINT=3. (FNF) ! 900320 Added E0's to DATA statement for X to reduce single/double ! differences, and other minor cosmetic changes. ! 900320 Converted to double precision. ! 900321 Removed IFAIL from call sequence for SLATEC standards and ! made miscellaneous cosmetic changes. (FNF) ! 900322 Minor changes to reduce single/double differences. (FNF) ! 900530 Tolerance (TOLD) and argument to DPCHIC changed. (WRB) ! 900802 Modified TOLD formula and constants in DPCHIC calls to ! correct DPCHQ3 failures. (FNF) ! 901130 Several significant changes: (FNF) ! 1. Changed comparison between DPCHIM and DPCHIC to only ! require agreement to machine precision. ! 2. Revised to print more output when KPRINT=3. ! 3. Added 1P's to formats. ! 910708 Minor modifications in use of KPRINT. (WRB) ! 930317 Improved output formats. (FNF) !***END PROLOGUE DPCHQ3 ! !*Internal Notes: ! ! TOLD is used to compare with stored Cray results. Its value ! should be consistent with significance of stored values. ! TOLZ is used for cases in which exact equality is expected. ! TOL is used for cases in which agreement to machine precision ! is expected. !**End ! ! Declare arguments. ! subroutine DPCHQ3 (LUN, KPRINT, IPASS) integer LUN, KPRINT, IPASS LOGICAL COMP ! ! Declare variables. ! double precision d1mach integer I, IC(2), IERR, IFAIL, N, NBAD, NBADZ, NWK PARAMETER (N = 9, NWK = 2*N) double precision D(N), DC(N), DC5, DC6, DM(N), DS(N), ERR, F(N), & MONE, TOL, TOLD, TOLZ, VC(2), X(N), WK(NWK), ZERO PARAMETER (ZERO = 0.0D0, MONE = -1.0D0) ! ! Initialize. ! ! Data. CHARACTER*6 RESULT DATA IC /0, 0/ DATA X /-2.2D0,-1.2D0,-1.0D0,-0.5D0,-0.01D0, 0.5D0, 1.0D0, & ! ! Results generated on Cray X/MP (9 sign. figs.) 2.0D0, 2.2D0/ DATA DM / 0. , 3.80027352D-01, 7.17253009D-01, & 5.82014161D-01, 0. ,-5.68208031D-01, & -5.13501618D-01,-7.77910977D-02,-2.45611117D-03/ DATA DC5,DC6 / 1.76950158D-02,-5.69579814D-01/ DATA DS /-5.16830792D-02, 5.71455855D-01, 7.40530225D-01, & 7.63864934D-01, 1.92614386D-02,-7.65324380D-01, & ! !***FIRST EXECUTABLE STATEMENT DPCHQ3 -7.28209035D-01,-7.98445427D-02,-2.85983446D-02/ ! ! Set tolerances. IFAIL = 0 TOL = 10*d1mach(4) TOLD = max ( 1.0D-7, 10*TOL ) ! TOLZ = ZERO if ( kprint >= 3) write (LUN, 1000) ! ! Set up data. ! if ( kprint >= 2) write (LUN, 1001) DO 10 I = 1, N F(I) = EXP(-X(I)**2) ! 10 continue if ( kprint >= 3) THEN write (LUN, 1002) DO 12 I = 1, 4 write (LUN, 1010) X(I), F(I), DM(I), DS(I) 12 continue write (LUN, 1011) X(5), F(5), DM(5), DC5, DS(5) write (LUN, 1011) X(6), F(6), DM(6), DC6, DS(6) DO 15 I = 7, N write (LUN, 1010) X(I), F(I), DM(I), DS(I) 15 continue ! ! Test DPCHIM. ! end if ! -------------------------------- if ( KPRINT >= 3) write (LUN, 2000) 'IM' ! -------------------------------- ! Expect IERR=1 (one monotonicity switch). call DPCHIM (N, X, F, D, 1, IERR) if ( KPRINT >= 3 ) write (LUN, 2001) 1 if ( .NOT.COMP (IERR, 1, LUN, KPRINT) ) THEN IFAIL = IFAIL + 1 else if ( KPRINT >= 3 ) write (LUN, 2002) NBAD = 0 NBADZ = 0 DO 20 I = 1, N ! D-values should agree with stored values. ! (Zero values should agree exactly.) RESULT = ' OK' if ( DM(I) == ZERO ) THEN ERR = ABS( D(I) ) if ( ERR > TOLZ ) THEN NBADZ = NBADZ + 1 RESULT = '**BADZ' end if else ERR = ABS( (D(I)-DM(I))/DM(I) ) if ( ERR > TOLD ) THEN NBAD = NBAD + 1 RESULT = '**BAD' end if end if if ( KPRINT >= 3) & write (LUN, 2003) I, X(I), D(I), ERR, RESULT 20 continue if ( (NBADZ /= 0).OR.(NBAD /= 0) ) THEN IFAIL = IFAIL + 1 if ( (NBADZ /= 0) .and. (KPRINT >= 2)) & write (LUN, 2004) NBAD if ( (NBAD /= 0) .and. (KPRINT >= 2)) & write (LUN, 2005) NBAD, 'IM', TOLD else if ( KPRINT >= 2) write (LUN, 2006) 'IM' end if ! ! Test DPCHIC -- options set to reproduce DPCHIM. ! end if ! -------------------------------------------------------- if ( KPRINT >= 3) write (LUN, 2000) 'IC' ! -------------------------------------------------------- ! Expect IERR=0 . call DPCHIC (IC, VC, ZERO, N, X, F, DC, 1, WK, NWK, IERR) if ( KPRINT >= 3 ) write (LUN, 2001) 0 if ( .NOT.COMP (IERR, 0, LUN, KPRINT) ) THEN IFAIL = IFAIL + 1 else if ( KPRINT >= 3 ) write (LUN, 2002) NBAD = 0 DO 30 I = 1, N ! D-values should agree exactly with those computed by DPCHIM. ! (To be generous, will only test to machine precision.) RESULT = ' OK' ERR = ABS( D(I)-DC(I) ) if ( ERR > TOL ) THEN NBAD = NBAD + 1 RESULT = '**BAD' end if if ( KPRINT >= 3) & write (LUN, 2003) I, X(I), DC(I), ERR, RESULT 30 continue if ( NBAD /= 0 ) THEN IFAIL = IFAIL + 1 if ( KPRINT >= 2) write (LUN, 2005) NBAD, 'IC', TOL else if ( KPRINT >= 2) write (LUN, 2006) 'IC' end if ! ! Test DPCHIC -- default nonzero switch derivatives. ! end if ! ------------------------------------------------------- if ( KPRINT >= 3) write (LUN, 2000) 'IC' ! ------------------------------------------------------- ! Expect IERR=0 . call DPCHIC (IC, VC, MONE, N, X, F, D, 1, WK, NWK, IERR) if ( KPRINT >= 3 ) write (LUN, 2001) 0 if ( .NOT.COMP (IERR, 0, LUN, KPRINT) ) THEN IFAIL = IFAIL + 1 else if ( KPRINT >= 3 ) write (LUN, 2002) NBAD = 0 NBADZ = 0 DO 40 I = 1, N ! D-values should agree exactly with those computed in ! previous call, except at points 5 and 6. RESULT = ' OK' if ( (I < 5).OR.(I > 6) ) THEN ERR = ABS( D(I)-DC(I) ) if ( ERR > TOLZ ) THEN NBADZ = NBADZ + 1 RESULT = '**BADA' end if else if ( I == 5 ) THEN ERR = ABS( (D(I)-DC5)/DC5 ) else ERR = ABS( (D(I)-DC6)/DC6 ) end if if ( ERR > TOLD ) THEN NBAD = NBAD + 1 RESULT = '**BAD' end if end if if ( KPRINT >= 3) & write (LUN, 2003) I, X(I), D(I), ERR, RESULT 40 continue if ( (NBADZ /= 0).OR.(NBAD /= 0) ) THEN IFAIL = IFAIL + 1 if ( (NBADZ /= 0) .and. (KPRINT >= 2)) & write (LUN, 2007) NBAD if ( (NBAD /= 0) .and. (KPRINT >= 2)) & write (LUN, 2005) NBAD, 'IC', TOLD else if ( KPRINT >= 2) write (LUN, 2006) 'IC' end if ! ! Test DPCHSP. ! end if ! ------------------------------------------------- if ( KPRINT >= 3) write (LUN, 2000) 'SP' ! ------------------------------------------------- ! Expect IERR=0 . call DPCHSP (IC, VC, N, X, F, D, 1, WK, NWK, IERR) if ( KPRINT >= 3 ) write (LUN, 2001) 0 if ( .NOT.COMP (IERR, 0, LUN, KPRINT) ) THEN IFAIL = IFAIL + 1 else if ( KPRINT >= 3 ) write (LUN, 2002) NBAD = 0 DO 50 I = 1, N ! D-values should agree with stored values. RESULT = ' OK' ERR = ABS( (D(I)-DS(I))/DS(I) ) if ( ERR > TOLD ) THEN NBAD = NBAD + 1 RESULT = '**BAD' end if if ( KPRINT >= 3) & write (LUN, 2003) I, X(I), D(I), ERR, RESULT 50 continue if ( NBAD /= 0 ) THEN IFAIL = IFAIL + 1 if ( KPRINT >= 2) write (LUN, 2005) NBAD, 'SP', TOLD else if ( KPRINT >= 2) write (LUN, 2006) 'SP' end if ! ! PRINT SUMMARY AND TERMINATE. ! end if ! if ( (KPRINT >= 2) .and. (IFAIL /= 0)) write (LUN, 3001) IFAIL if ( IFAIL == 0) THEN ipass = 1 if ( KPRINT >= 2) WRITE(LUN,99998) else ipass = 0 if ( KPRINT >= 1) WRITE(LUN,99999) end if ! ! FORMATS. ! return 1000 FORMAT ('1'//10X,'TEST DPCHIP INTERPOLATORS') 1001 FORMAT (//10X,'DPCHQ3 RESULTS'/10X,'--------------') 1002 FORMAT (// 5X,'DATA:' & /39X,'---------- EXPECTED D-VALUES ----------' & /12X,'X',9X,'F',18X,'DM',13X,'DC',13X,'DS') 1010 FORMAT (5X,F10.2,1P,D15.5,4X,D15.5,15X,D15.5) 1011 FORMAT (5X,F10.2,1P,D15.5,4X,3D15.5) 2000 FORMAT (/5X,'DPCH',A2,' TEST:') 2001 FORMAT (15X,'EXPECT IERR =',I5) 2002 FORMAT (/9X,'I',7X,'X',9X,'D',13X,'ERR') 2003 FORMAT (5X,I5,F10.2,1P,2D15.5,2X,A) 2004 FORMAT (/' **',I5,' DPCHIM RESULTS FAILED TO BE EXACTLY ZERO.') 2005 FORMAT (/' **',I5,' DPCH',A2,' RESULTS FAILED TOLERANCE TEST.', & ' TOL =',1P,D10.3) 2006 FORMAT (/5X,' ALL DPCH',A2,' RESULTS OK.') 2007 FORMAT (/' **',I5,' DPCHIC RESULTS FAILED TO AGREE WITH', & ' PREVIOUS CALL.') 3001 FORMAT (/' *** TROUBLE ***',I5,' INTERPOLATION TESTS FAILED.') 99998 FORMAT (/' ------------ DPCHIP PASSED ALL INTERPOLATION TESTS', & ' ------------') 99999 FORMAT (/' ************ DPCHIP FAILED SOME INTERPOLATION TESTS', & ! -------- LAST LINE OF DPCHQ3 FOLLOWS ----------------------------- ' ************') end !! DPCHQ4 !***PURPOSE Test the PCHIP monotonicity checker DPCHCM. !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (PCHQK4-S, DPCHQ4-D) !***KEYWORDS PCHIP MONOTONICITY CHECKER QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! DPCHIP QUICK CHECK NUMBER 4 ! ! TESTS THE MONOTONICITY CHECKER: DPCHCM. ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call DPCHQ4 (LUN, KPRINT, IPASS) ! ! *Arguments: ! ! LUN :IN is the unit number to which output is to be written. ! ! KPRINT:IN controls the amount of output, as specified in the ! SLATEC Guidelines. ! ! IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. ! IPASS=0 indicates one or more tests failed. ! ! *Description: ! ! This routine tests a constructed data set with three different ! INCFD settings and compares with the expected results. It then ! runs a special test to check for bug in overall monotonicity found ! in DPCHMC. Finally, it reverses the data and repeats all tests. ! !***ROUTINES CALLED DPCHCM !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 890306 Changed LOUT to LUN and added it to call list. (FNF) ! 890316 Removed DATA statements to suit new quick check standards. ! 890410 Changed PCHMC to PCHCM. ! 890410 Added a SLATEC 4.0 format prologue. ! 900314 Changed name from PCHQK3 to PCHQK4 and improved some output ! formats. ! 900315 Revised prologue and improved some output formats. (FNF) ! 900320 Converted to double precision. ! 900321 Removed IFAIL from call sequence for SLATEC standards and ! made miscellaneous cosmetic changes. (FNF) ! 900322 Added declarations so all variables are declared. (FNF) ! 910708 Minor modifications in use of KPRINT. (WRB) ! 930317 Improved output formats. (FNF) !***END PROLOGUE DPCHQ4 ! !*Internal Notes: ! ! Data set-up is done via assignment statements to avoid modifying ! DATA-loaded arrays, as required by the 1989 SLATEC Guidelines. ! Run with KPRINT=3 to display the data. !**End ! ! Declare arguments. ! subroutine DPCHQ4 (LUN, KPRINT, IPASS) ! ! DECLARE VARIABLES. ! integer LUN, KPRINT, IPASS integer MAXN, MAXN2, MAXN3, NB PARAMETER (MAXN = 16, MAXN2 = 8, MAXN3 = 6, NB = 7) integer I, IERR, IFAIL, INCFD, ISMEX1(MAXN), ISMEX2(MAXN2), & ISMEX3(MAXN3), ISMEXB(NB), ISMON(MAXN), K, N, NS(3) double precision D(MAXN), DB(NB), F(MAXN), FB(NB), X(MAXN) ! ! DEFINE EXPECTED RESULTS. ! LOGICAL SKIP DATA ISMEX1 / 1, 1,-1, 1, 1,-1, 1, 1,-1, 1, 1,-1, 1, 1,-1, 2/ DATA ISMEX2 / 1, 2, 2, 1, 2, 2, 1, 2/ DATA ISMEX3 / 1, 1, 1, 1, 1, 1/ ! ! DEFINE TEST DATA. ! DATA ISMEXB / 1, 3, 1, -1, -3, -1, 2/ ! !***FIRST EXECUTABLE STATEMENT DPCHQ4 DATA NS /16, 8, 6/ if ( kprint >= 3) write (LUN, 1000) ! ! Define X, F, D. if ( kprint >= 2) write (LUN, 1001) DO 1 I = 1, MAXN X(I) = I D(I) = 0.D0 1 continue DO 2 I = 2, MAXN, 3 D(I) = 2.D0 2 continue DO 3 I = 1, 3 F(I) = X(I) F(I+ 3) = F(I ) + 1.D0 F(I+ 6) = F(I+3) + 1.D0 F(I+ 9) = F(I+6) + 1.D0 F(I+12) = F(I+9) + 1.D0 3 continue ! Define FB, DB. F(16) = 6.D0 FB(1) = 0.D0 FB(2) = 2.D0 FB(3) = 3.D0 FB(4) = 5.D0 DB(1) = 1.D0 DB(2) = 3.D0 DB(3) = 3.D0 DB(4) = 0.D0 DO I = 1, 3 FB(NB-I+1) = FB(I) DB(NB-I+1) = -DB(I) end do ! ! INITIALIZE. ! IFAIL = 0 if ( kprint >= 3) THEN write (LUN, 1002) DO 10 I = 1, NB write (LUN, 1010) I, X(I), F(I), D(I), FB(I), DB(I) 10 continue DO 20 I = NB+1, MAXN write (LUN, 1010) I, X(I), F(I), D(I) 20 continue ! ! TRANSFER POINT FOR SECOND SET OF TESTS. ! end if ! ! Loop over a series of values of INCFD. ! 25 continue DO 30 INCFD = 1, 3 N = NS(INCFD) SKIP = .FALSE. call DPCHCM (N, X, F, D, INCFD, SKIP, ISMON, IERR) if ( KPRINT >= 3) & write (LUN, 2000) INCFD, IERR, (ISMON(I), I=1,N) if ( IERR /= 0 ) THEN IFAIL = IFAIL + 1 if ( KPRINT >= 3) write (LUN,2001) else DO 29 I = 1, N if ( INCFD == 1) THEN if ( ISMON(I) /= ISMEX1(I) ) THEN IFAIL = IFAIL + 1 if ( KPRINT >= 3) & write (LUN, 2002) (ISMEX1(K),K=1,N) GO TO 30 end if else if ( INCFD == 2 ) then if ( ISMON(I) /= ISMEX2(I) ) THEN IFAIL = IFAIL + 1 if ( KPRINT >= 3) & write (LUN, 2002) (ISMEX2(K),K=1,N) GO TO 30 end if else if ( ISMON(I) /= ISMEX3(I) ) THEN IFAIL = IFAIL + 1 if ( KPRINT >= 3) & write (LUN, 2002) (ISMEX3(K),K=1,N) GO TO 30 end if end if 29 continue end if ! ! Test for -1,3,1 bug. ! 30 continue SKIP = .FALSE. call DPCHCM (NB, X, FB, DB, 1, SKIP, ISMON, IERR) if ( KPRINT >= 3) & write (LUN, 2030) IERR, (ISMON(I), I=1,NB) if ( IERR /= 0 ) THEN IFAIL = IFAIL + 1 if ( KPRINT >= 3) write (LUN,2001) else DO 34 I = 1, NB if ( ISMON(I) /= ISMEXB(I) ) THEN IFAIL = IFAIL + 1 if ( KPRINT >= 3) & write (LUN, 2002) (ISMEXB(K),K=1,NB) GO TO 35 end if 34 continue end if ! 35 continue ! ! Change sign and do again. ! if ( F(1) < 0.) GO TO 90 if ( KPRINT >= 3) write (LUN, 2050) DO 40 I = 1, MAXN F(I) = -F(I) D(I) = -D(I) if ( ISMEX1(I) /= 2 ) ISMEX1(I) = -ISMEX1(I) 40 continue DO 42 I = 1, MAXN2 if ( ISMEX2(I) /= 2 ) ISMEX2(I) = -ISMEX2(I) 42 continue DO 43 I = 1, MAXN3 if ( ISMEX3(I) /= 2 ) ISMEX3(I) = -ISMEX3(I) 43 continue DO 50 I = 1, NB FB(I) = -FB(I) DB(I) = -DB(I) if ( ISMEXB(I) /= 2 ) ISMEXB(I) = -ISMEXB(I) 50 continue ! ! PRINT SUMMARY AND TERMINATE. ! GO TO 25 90 continue ! if ( (KPRINT >= 2) .and. (IFAIL /= 0)) write (LUN, 3001) IFAIL if ( IFAIL == 0) THEN ipass = 1 if ( KPRINT >= 2) WRITE(LUN,99998) else ipass = 0 if ( KPRINT >= 1) WRITE(LUN,99999) ! end if ! ! FORMATS. ! return 1000 FORMAT ('1'//10X,'TEST DPCHIP MONOTONICITY CHECKER') 1001 FORMAT (//10X,'DPCHQ4 RESULTS'/10X,'--------------') 1002 FORMAT (// 5X,'DATA:' & // 9X,'I',4X,'X',5X,'F',5X,'D',5X,'FB',4X,'DB') 1010 FORMAT (5X,I5,5F6.1) 2000 FORMAT (/4X,'INCFD =',I2,': IERR =',I3/15X,'ISMON =',16I3) 2001 FORMAT (' *** Failed -- bad IERR value.') 2002 FORMAT (' *** Failed -- expect:',16I3) 2030 FORMAT (/4X,' Bug test: IERR =',I3/15X,'ISMON =',7I3) 2050 FORMAT (/4X,'Changing sign of data.....') 3001 FORMAT (/' *** TROUBLE ***',I5,' MONOTONICITY TESTS FAILED.') 99998 FORMAT (/' ------------ DPCHIP PASSED ALL MONOTONICITY TESTS', & ' ------------') 99999 FORMAT (/' ************ DPCHIP FAILED SOME MONOTONICITY TESTS', & ! -------- LAST LINE OF DPCHQ4 FOLLOWS ----------------------------- ' ************') end !! DPCHQ5 !***PURPOSE Test the PCH to B-spline conversion routine DPCHBS. !***LIBRARY SLATEC (PCHIP) !***TYPE DOUBLE PRECISION (PCHQK5-S, DPCHQ5-D) !***KEYWORDS PCHIP CONVERSION ROUTINE QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! DPCHIP QUICK CHECK NUMBER 5 ! ! TESTS THE CONVERSION ROUTINE: DPCHBS. ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call DPCHQ5 (LUN, KPRINT, IPASS) ! ! *Arguments: ! ! LUN :IN is the unit number to which output is to be written. ! ! KPRINT:IN controls the amount of output, as specified in the ! SLATEC Guidelines. ! ! IPASS:OUT will contain a pass/fail flag. IPASS=1 is good. ! IPASS=0 indicates one or more tests failed. ! ! *Description: ! ! This routine tests a constructed data set with four different ! KNOTYP settings. It computes the function and derivatives of the ! resulting B-representation via DBVALU and compares with PCH data. ! ! *Caution: ! This routine assumes DBVALU has already been successfully tested. ! !***ROUTINES CALLED DBVALU, DPCHBS, d1mach !***REVISION HISTORY (YYMMDD) ! 900411 DATE WRITTEN ! 900412 Corrected minor errors in initial implementation. ! 900430 Produced double precision version. ! 900501 Corrected declarations. ! 930317 Improved output formats. (FNF) !***END PROLOGUE DPCHQ5 ! !*Internal Notes: ! TOL is the tolerance to use for quantities that should only ! theoretically be equal. ! TOLZ is the tolerance to use for quantities that should be exactly ! equal. ! !**End ! ! Declare arguments. ! subroutine DPCHQ5 (LUN, KPRINT, IPASS) ! ! Declare externals. ! integer LUN, KPRINT, IPASS double precision DBVALU, d1mach ! ! Declare variables. ! EXTERNAL DBVALU, DPCHBS, d1mach integer I, IERR, IFAIL, INBV, J, KNOTYP, K, N, NDIM, NKNOTS PARAMETER (N = 9) double precision BCOEF(2*N), D(N), DCALC, DERR, DERMAX, F(N), & FCALC, FERR, FERMAX, T(2*N+4), TERR, TERMAX, TOL, TOLZ, & TSAVE(2*N+4), WORK(16*N), X(N), ZERO PARAMETER (ZERO = 0.0D0) ! ! Define relative error function. ! LOGICAL FAIL double precision ANS, ERR, RELERR ! ! Define test data. ! RELERR (ERR, ANS) = ABS(ERR) / max ( 1.0D-5,ABS(ANS)) DATA X /-2.2D0, -1.2D0, -1.0D0, -0.5D0, -0.01D0, & 0.5D0, 1.0D0, 2.0D0, 2.2D0/ DATA F / 0.0079D0, 0.2369D0, 0.3679D0, 0.7788D0, 0.9999D0, & 0.7788D0, 0.3679D0, 0.1083D0, 0.0079D0/ DATA D / 0.0000D0, 0.3800D0, 0.7173D0, 0.5820D0, 0.0177D0, & ! ! Initialize. ! !***FIRST EXECUTABLE STATEMENT DPCHQ5 -0.5696D0,-0.5135D0,-0.0778D0,-0.0025D0/ IFAIL = 0 TOL = 100*d1mach(4) ! TOLZ = ZERO if ( KPRINT >= 3) write (LUN, 1000) ! ! Loop over a series of values of KNOTYP. ! if ( KPRINT >= 2) write (LUN, 1001) if ( KPRINT >= 3) write (LUN, 1010) ! ------------ DO 300 KNOTYP = 2, -1, -1 call DPCHBS (N, X, F, D, 1, KNOTYP, NKNOTS, T, BCOEF, NDIM, K, & ! ------------ IERR) if ( KPRINT >= 3) & write (LUN, 2000) KNOTYP, NKNOTS, NDIM, K, IERR if ( IERR /= 0 ) THEN IFAIL = IFAIL + 1 if ( KPRINT >= 3) write (LUN, 2001) ! Compare evaluated results with inputs to DPCHBS. else INBV = 1 FERMAX = ZERO DERMAX = ZERO if ( KPRINT >= 3) THEN write (LUN, 2002) write (LUN, 2003) T(1), T(2) J = 1 end if DO 100 I = 1, N FCALC = DBVALU (T, BCOEF, NDIM, K, 0, X(I), INBV, WORK) FERR = F(I) - FCALC FERMAX = max ( FERMAX, RELERR(FERR,F(I)) ) DCALC = DBVALU (T, BCOEF, NDIM, K, 1, X(I), INBV, WORK) DERR = D(I) - DCALC DERMAX = max ( DERMAX, RELERR(DERR,D(I)) ) if ( KPRINT >= 3) THEN J = J + 2 write (LUN, 2004) X(I), T(J), T(J+1), F(I), FERR, & D(I), DERR end if 100 continue if ( KPRINT >= 3) THEN J = J + 2 write (LUN, 2003) T(J), T(J+1) end if FAIL = (FERMAX > TOL).OR.(DERMAX > TOL) if ( FAIL) IFAIL = IFAIL + 1 if ( (KPRINT >= 3).OR.(KPRINT>=2) .and. FAIL) & write (LUN, 2005) FERMAX, DERMAX, TOL ! ! Special check for KNOTYP=-1. end if ! Save knot vector for next test. if ( KNOTYP == 0) THEN DO 200 I = 1, NKNOTS TSAVE(I) = T(I) 200 continue ! Check that knot vector is unchanged. else if ( KNOTYP == -1) THEN TERMAX = ZERO DO 250 I = 1, NKNOTS TERR = ABS(T(I) - TSAVE(I)) TERMAX = max ( TERMAX, TERR) 250 continue if ( TERMAX > TOLZ) THEN IFAIL = IFAIL + 1 if ( KPRINT >= 2) write (LUN, 2007) TERMAX, TOLZ end if end if ! ! PRINT SUMMARY AND TERMINATE. ! 300 continue ! if ( (KPRINT >= 2) .and. (IFAIL /= 0)) write (LUN, 3001) IFAIL if ( IFAIL == 0) THEN ipass = 1 if ( KPRINT >= 2) WRITE(LUN,99998) else ipass = 0 if ( KPRINT >= 1) WRITE(LUN,99999) ! end if ! ! FORMATS. ! return 1000 FORMAT ('1'//10X,'TEST PCH TO B-SPLINE CONVERTER') 1001 FORMAT (//10X,'DPCHQ5 RESULTS'/10X,'--------------') 1010 FORMAT (/4X,'(Results should be the same for all KNOTYP values.)') 2000 FORMAT (/4X,'KNOTYP =',I2,': NKNOTS =',I3,', NDIM =',I3, & ', K =',I2,', IERR =',I3) 2001 FORMAT (' *** Failed -- bad IERR value.') 2002 FORMAT (/15X,'X',9X,'KNOTS',10X,'F',7X,'FERR',8X,'D',7X,'DERR') 2003 FORMAT (18X,2F8.2) 2004 FORMAT (10X,3F8.2,F10.4,1P,D10.2,0P,F10.4,1P,D10.2) 2005 FORMAT (/5X,'Maximum relative errors:' & /15X,'F-error =',1P,D13.5,5X,'D-error =',D13.5 & /5X,'Both should be less than TOL =',D13.5) 2007 FORMAT (/' *** T-ARRAY MAXIMUM CHANGE =',1P,D13.5, & '; SHOULD NOT EXCEED TOLZ =',D13.5) 3001 FORMAT (/' *** TROUBLE ***',I5,' CONVERSION TESTS FAILED.') 99998 FORMAT (/' ------------ DPCHIP PASSED ALL CONVERSION TESTS', & ' ------------') 99999 FORMAT (/' ************ DPCHIP FAILED SOME CONVERSION TESTS', & ! -------- LAST LINE OF DPCHQ5 FOLLOWS ----------------------------- ' ************') end !! DPFITT !***PURPOSE Quick check for DPOLFT, DPCOEF and DP1VLU. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (PFITQX-S, DPFITT-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED d1mach, DCMPAR, DP1VLU, DPCOEF, DPOLFT, PASS, ! XERCLR, XGETF, XSETF !***COMMON BLOCKS DCHECK !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 890921 Realigned order of variables in the COMMON block. ! (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900911 Test problem changed and cosmetic changes to code. (WRB) ! 901205 Changed usage of d1mach(3) to d1mach(4) and modified the ! FORMATs. (RWC) ! 910708 Minor modifications in use of KPRINT. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900911 Test problem changed and cosmetic changes to code. (WRB) ! 920214 Code restructured to test for all values of kprint and to ! provide more PASS/FAIL information. (WRB) !***END PROLOGUE DPFITT ! .. Scalar Arguments .. subroutine DPFITT (LUN, KPRINT, IPASS) ! .. Scalars in Common .. integer IPASS, KPRINT, LUN double precision EPS, RP, SVEPS, TOL ! .. Arrays in Common .. integer IERP, IERR, NORD, NORDP ! .. Local Scalars .. double precision R(11) double precision YFIT ! .. Local Arrays .. integer I, ICNT, M, MAXORD double precision A(97), TC(5), W(11), X(11), Y(11), YP(5) ! .. External Functions .. integer ITEST(9) double precision d1mach ! .. External Subroutines .. EXTERNAL d1mach ! .. Intrinsic Functions .. EXTERNAL DCMPAR, PASS, DPCOEF, DPOLFT, DP1VLU ! .. Common blocks .. INTRINSIC ABS, SQRT !***FIRST EXECUTABLE STATEMENT DPFITT COMMON /DCHECK/ EPS, R, RP, SVEPS, TOL, NORDP, NORD, IERP, IERR ! ! Initialize variables for testing passage or failure of tests ! if ( kprint >= 2) write (LUN,FMT=9000) DO 100 I = 1,9 ITEST(I) = 0 100 continue ICNT = 0 TOL = SQRT(d1mach(4)) M = 11 DO 110 I = 1,M X(I) = I - 6 Y(I) = X(I)**4 ! ! Test DPOLFT ! Input EPS is negative - specified level ! 110 continue W(1) = -1.0D0 EPS = -0.01D0 SVEPS = EPS MAXORD = 8 NORDP = 4 RP = 625.0D0 IERP = 1 ! ! See if test passed ! call DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) ! ! Check for suppression of printing. ! call DCMPAR (ICNT, ITEST) if ( kprint == 0) GO TO 130 if ( kprint == 1 .and. ITEST(ICNT) == 1) GO TO 130 write (LUN,FMT=9010) write (LUN,FMT=9020) if ( kprint <= 2 .and. ITEST(ICNT) == 1) GO TO 120 write (LUN,FMT=9030) SVEPS,NORDP,RP,IERP ! ! Send message indicating passage or failure of test ! write (LUN,FMT=9040) EPS,NORD,R(11),IERR ! ! Input EPS is negative - computed level ! 120 call PASS (LUN, ICNT, ITEST(ICNT)) 130 EPS = -1.0D0 SVEPS = EPS ! ! See if test passed ! call DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) ! ! Check for suppression of printing. ! call DCMPAR (ICNT, ITEST) if ( kprint == 0) GO TO 150 if ( kprint == 1 .and. ITEST(ICNT) == 1) GO TO 150 write (LUN,FMT=9050) if ( kprint <= 2 .and. ITEST(ICNT) == 1) GO TO 140 write (LUN,FMT=9060) MAXORD write (LUN,FMT=9030) SVEPS,NORDP,RP,IERP ! ! Send message indicating passage or failure of test ! write (LUN,FMT=9040) EPS,NORD,R(11),IERR ! ! Input EPS is zero ! 140 call PASS (LUN, ICNT, ITEST(ICNT)) 150 W(1) = -1.0D0 EPS = 0.0D0 SVEPS = EPS NORDP = 5 MAXORD = 5 ! ! See if test passed ! call DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) ! ! Check for suppression of printing. ! call DCMPAR (ICNT, ITEST) if ( kprint == 0) GO TO 170 if ( kprint == 1 .and. ITEST(ICNT) == 1) GO TO 170 write (LUN,FMT=9070) if ( kprint <= 2 .and. ITEST(ICNT) == 1) GO TO 160 write (LUN,FMT=9060) MAXORD write (LUN,FMT=9030) SVEPS,NORDP,RP,IERP ! ! Send message indicating passage or failure of test ! write (LUN,FMT=9040) EPS,NORD,R(11),IERR ! ! Input EPS is positive ! 160 call PASS (LUN, ICNT, ITEST(ICNT)) 170 IERP = 1 NORDP = 4 EPS = 75.0D0*d1mach(4) SVEPS = EPS ! ! See if test passed ! call DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) ! ! Check for suppression of printing. ! call DCMPAR (ICNT, ITEST) if ( kprint == 0) GO TO 190 if ( kprint == 1 .and. ITEST(ICNT) == 1) GO TO 190 write (LUN,FMT=9080) if ( kprint <= 2 .and. ITEST(ICNT) == 1) GO TO 180 write (LUN,FMT=9060) MAXORD write (LUN,FMT=9030) SVEPS,NORDP,RP,IERP ! ! Send message indicating passage or failure of test ! write (LUN,FMT=9040) EPS,NORD,R(11),IERR ! ! Improper input ! 180 call PASS (LUN, ICNT, ITEST(ICNT)) 190 IERP = 2 ! ! Check for suppression of printing. ! M = -2 call XGETF (KONTRL) if ( kprint <= 2 ) then call XSETF (0) else call XSETF (1) end if ! call xerclr if ( kprint >= 3) write (LUN,9090) ! ! See if test passed ! call DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) ICNT = ICNT + 1 if ( IERR == 2 ) then ITEST(ICNT) = 1 if ( kprint >= 3 ) then write (LUN, 9100) 'PASSED', IERR end if else if ( kprint >= 2 ) then write (LUN, 9100) 'FAILED', IERR end if ! ! Check for suppression of printing. ! end if if ( kprint == 0) GO TO 210 if ( kprint == 1 .and. ITEST(ICNT) == 1) GO TO 210 ! ! Send message indicating passage or failure of test ! if ( kprint <= 2 .and. ITEST(ICNT) == 1) GO TO 200 ! 200 call PASS (LUN, ICNT, ITEST(ICNT)) call xerclr ! ! MAXORD too small to meet RMS error ! call XSETF (KONTRL) 210 M = 11 W(1) = -1.0D0 EPS = 5.0D0*d1mach(4) SVEPS = EPS RP = 553.0D0 MAXORD = 2 IERP = 3 NORDP = 2 ! ! See if test passed ! call DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) ! ! Check for suppression of printing. ! call DCMPAR (ICNT, ITEST) if ( kprint == 0) GO TO 230 if ( kprint == 1 .and. ITEST(ICNT) == 1) GO TO 230 write (LUN,FMT=9110) if ( kprint <= 2 .and. ITEST(ICNT) == 1) GO TO 220 write (LUN,FMT=9060) MAXORD write (LUN,FMT=9030) SVEPS,NORDP,RP,IERP ! ! Send message indicating passage or failure of test ! write (LUN,FMT=9040) EPS,NORD,R(11),IERR ! ! MAXORD too small to meet statistical test ! 220 call PASS (LUN, ICNT, ITEST(ICNT)) 230 NORDP = 4 IERP = 4 RP = 625.0D0 EPS = -0.01D0 SVEPS = EPS MAXORD = 5 ! ! See if test passed ! call DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) ! ! Check for suppression of printing. ! call DCMPAR (ICNT, ITEST) if ( kprint == 0) GO TO 250 if ( kprint == 1 .and. ITEST(ICNT) == 1) GO TO 250 write (LUN,FMT=9120) if ( kprint <= 2 .and. ITEST(ICNT) == 1) GO TO 240 write (LUN,FMT=9060) MAXORD write (LUN,FMT=9030) SVEPS,NORDP,RP,IERP ! ! Send message indicating passage or failure of test ! write (LUN,FMT=9040) EPS,NORD,R(11),IERR ! ! Test DPCOEF ! 240 call PASS (LUN, ICNT, ITEST(ICNT)) 250 MAXORD = 6 EPS = 0.0D0 SVEPS = EPS Y(6) = 1.0D0 DO 260 I = 1,M W(I) = 1.0D0/(Y(I)**2) 260 continue Y(6) = 0.0D0 call DPOLFT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) ! ! See if test passed ! call DPCOEF (4, 5.0D0, TC, A) ICNT = ICNT + 1 ! ! Check for suppression of printing ! if ( ABS(R(11)-TC(1)) <= TOL) ITEST(ICNT) = 1 if ( kprint == 0) GO TO 280 if ( kprint == 1 .and. ITEST(ICNT) == 1) GO TO 280 write (LUN,FMT=9130) if ( kprint <= 2 .and. ITEST(ICNT) == 1) GO TO 270 ! ! Send message indicating passage or failure of test ! write (LUN,FMT=9140) R(11),TC(1) ! ! Test DP1VLU ! Normal call ! 270 call PASS (LUN, ICNT, ITEST(ICNT)) ! ! See if test passed ! 280 call DP1VLU (6, 0, X(8), YFIT, YP, A) ICNT = ICNT + 1 ! ! Check for suppression of printing ! if ( ABS(R(8)-YFIT) <= TOL) ITEST(ICNT) = 1 if ( kprint == 0) GO TO 300 if ( kprint == 1 .and. ITEST(ICNT) == 1) GO TO 300 write (LUN,FMT=9150) write (LUN,FMT=9160) if ( kprint <= 2 .and. ITEST(ICNT) == 1) GO TO 290 ! ! Send message indicating passage or failure of test ! write (LUN,FMT=9170) X(8),R(8),YFIT ! ! Check to see if all tests passed ! 290 call PASS (LUN, ICNT, ITEST(ICNT)) 300 ipass = 1 DO 310 I = 1,9 ipass = IPASS*ITEST(I) ! 310 continue if ( ipass == 1 .and. KPRINT >= 3) write (LUN,FMT=9180) if ( ipass == 0 .and. KPRINT >= 2) write (LUN,FMT=9190) ! return 9000 FORMAT ('1' / ' Test DPOLFT, DPCOEF and DP1VLU') 9010 FORMAT (' Exercise DPOLFT') 9020 FORMAT (' Input EPS is negative - specified significance level') 9030 FORMAT (' Input EPS = ', E15.8, ' correct order = ', I3, & ' R(1) = ', E15.8, ' IERR = ', I1) 9040 FORMAT (' Output EPS = ', E15.8, ' computed order = ', I3, & ' R(1) = ', E15.8, ' IERR = ', I1) 9050 FORMAT (/ ' Input EPS is negative - computed significance level') 9060 FORMAT (' Maximum order = ', I2) 9070 FORMAT (/ ' Input EPS is zero') 9080 FORMAT (/ ' Input EPS is positive') 9090 FORMAT (/ ' Invalid input') 9100 FORMAT (' DPOLFT incorrect argument test ', A / & ' IERR should be 2. It is ', I4) 9110 FORMAT (/ ' Cannot meet RMS error requirement') 9120 FORMAT (/ ' Cannot satisfy statistical test') 9130 FORMAT (/ ' Exercise DPCOEF') 9140 FORMAT (/ ' For C=1.0, correct coefficient = ', E15.8, & ' computed = ', E15.8) 9150 FORMAT (/ ' Exercise DP1VLU') 9160 FORMAT (' Normal execution') 9170 FORMAT (' For X = ', F5.2, ' correct P(X) = ', E15.8, & ' P(X) from DP1VLU = ', E15.8) 9180 FORMAT (/' ***************DPOLFT PASSED ALL TESTS***************') 9190 FORMAT (/' ***************DPOLFT FAILED SOME TESTS**************') end !! DPLPQX !***PURPOSE Quick check for DSPLP. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SPLPQX-S, DPLPQX-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED DCOPY, DSPLP, DUSRMT, PASS !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901013 Added additional printout on failure. (RWC) !***END PROLOGUE DPLPQX subroutine DPLPQX (LUN, KPRINT, IPASS) IMPLICIT DOUBLE PRECISION (A-H,O-Z) EXTERNAL DUSRMT integer ICNT, IND(60), IBASIS(60), IPASS, IWORK(900), ISOLN(14) double precision COSTS(37) double precision PRGOPT(50), DATTRV(210), BL(60), BU(60) double precision PRIMAL(60), DUALS(60) double precision WORK(800) double precision D(14,37) double precision ZERO !***FIRST EXECUTABLE STATEMENT DPLPQX integer MRELAS,NVARS,INFO,LW,LIW if ( KPRINT >= 2) WRITE(LUN,999) 999 FORMAT ('1 DSPLP QUICK CHECK') ICNT=1 ZERO = 0.0D0 ! DEFINE WORKING ARRAY LENGTHS IPASS=0 LIW = 900 LW = 800 MRELAS = 14 ! DEFINE THE ARRAY COSTS(*) FOR THE OBJECTIVE FUNCTION NVARS = 37 COSTS(1) = 1.030D0 COSTS(2) = 0.985D0 COSTS(3) = 0.997D0 COSTS(4) = 1.036D0 COSTS(5) = 1.005D0 COSTS(6) = 0.980D0 COSTS(7) = 1.004D0 COSTS(8) = 0.993D0 COSTS(9) = 1.018D0 COSTS(10) = 0.947D0 COSTS(11) = 0.910D0 COSTS(12) = 1.028D0 COSTS(13) = 0.957D0 COSTS(14) = 1.025D0 COSTS(15) = 1.036D0 COSTS(16) = 1.060D0 COSTS(17) = 0.954D0 COSTS(18) = 0.891D0 COSTS(19) = 0.921D0 COSTS(20) = 1.040D0 COSTS(21) = 0.912D0 COSTS(22) = 0.926D0 COSTS(23) = 1.000D0 COSTS(24) = 0.000D0 COSTS(25) = 0.000D0 COSTS(26) = 0.000D0 COSTS(27) = 0.000D0 COSTS(28) = 0.000D0 COSTS(29) = 0.000D0 COSTS(30) = 0.000D0 COSTS(31) = 0.000D0 COSTS(32) = 0.000D0 COSTS(33) = 0.000D0 COSTS(34) = 0.000D0 COSTS(35) = 0.000D0 COSTS(36) = 0.000D0 ! PLACE THE NONZERO INFORMATION ABOUT THE MATRIX IN DATTRV(*) COSTS(37) = 0.000D0 call DCOPY(14*37, ZERO, 0, D, 1) D(1,1) = 1.04000D0 D(1,23) = 1.00000D0 D(1,24) = -1.00000D0 D(2,6) = 0.04125D0 D(2,7) = 0.05250D0 D(2,17) = 0.04875D0 D(2,24) = 1.00000D0 D(2,25) = -1.00000D0 D(3,8) = 0.05625D0 D(3,9) = 0.06875D0 D(3,11) = 0.02250D0 D(3,25) = 1.00000D0 D(3,26) = -1.00000D0 D(4,2) = 1.04000D0 D(4,3) = 1.05375D0 D(4,5) = 1.06125D0 D(4,12) = 0.08000D0 D(4,16) = 0.09375D0 D(4,18) = 0.03750D0 D(4,19) = 0.04625D0 D(4,20) = 0.08125D0 D(4,22) = 0.05250D0 D(4,26) = 1.00000D0 D(4,27) = -1.00000D0 D(5,10) = 0.04375D0 D(5,27) = 1.00000D0 D(5,28) = -1.00000D0 D(6,4) = 1.05875D0 D(6,13) = 0.04500D0 D(6,14) = 0.06375D0 D(6,15) = 0.06625D0 D(6,21) = 0.05000D0 D(6,28) = 1.00000D0 D(6,29) = -1.00000D0 D(7,6) = 1.04125D0 D(7,7) = 1.05250D0 D(7,8) = 1.05625D0 D(7,9) = 1.06875D0 D(7,11) = 0.02250D0 D(7,17) = 0.04875D0 D(7,29) = 1.00000D0 D(7,30) = -1.00000D0 D(8,10) = 1.04375D0 D(8,12) = 0.08000D0 D(8,13) = 0.04500D0 D(8,14) = 0.06375D0 D(8,15) = 0.06625D0 D(8,16) = 0.09375D0 D(8,18) = 0.03750D0 D(8,19) = 0.04625D0 D(8,20) = 0.08125D0 D(8,21) = 0.05000D0 D(8,22) = 0.05250D0 D(8,30) = 1.00000D0 D(8,31) = -1.00000D0 D(9,11) = 1.02250D0 D(9,17) = 0.04875D0 D(9,31) = 1.00000D0 D(9,32) = -1.00000D0 D(10,12) = 1.08000D0 D(10,13) = 1.04500D0 D(10,14) = 1.06375D0 D(10,15) = 1.06625D0 D(10,16) = 1.09375D0 D(10,18) = 0.03750D0 D(10,19) = 0.04625D0 D(10,20) = 0.08125D0 D(10,21) = 0.05000D0 D(10,22) = 0.05250D0 D(10,32) = 1.00000D0 D(10,33) = -1.00000D0 D(11,17) = 1.04875D0 D(11,33) = 1.00000D0 D(11,34) = -1.00000D0 D(12,18) = 1.03750D0 D(12,19) = 1.04625D0 D(12,20) = 1.08125D0 D(12,21) = 1.05000D0 D(12,22) = 0.05250D0 D(12,34) = 1.00000D0 D(12,35) = -1.00000D0 D(13,35) = 1.00000D0 D(13,36) = -1.00000D0 D(14,22) = 1.05250D0 D(14,36) = 1.00000D0 D(14,37) = -1.00000D0 KOUNT = 1 DO MM=1,NVARS DATTRV(KOUNT) = -MM DO KK=1,MRELAS if ( D(KK,MM) /= ZERO) then KOUNT = KOUNT + 1 DATTRV(KOUNT) = KK KOUNT = KOUNT + 1 DATTRV(KOUNT) = D(KK,MM) end if end do KOUNT = KOUNT + 1 end do ! ! NON-NEGATIVITY CONSTRAINT ! DATTRV(KOUNT) = ZERO DO IC=1,NVARS BL(IC) = ZERO IND(IC) = 3 BU(IC) = 10000000.000D0 end do ! ! LE CONSTRAINTS ! DO IV=1,MRELAS IVV = IV + NVARS IND(IVV) = 3 BL(IVV) = 100.00000D0 BU(IVV) = 100000000.00000D0 end do PRGOPT(01) = 18 PRGOPT(02) = 59 PRGOPT(03) = 0 PRGOPT(04) = 1 PRGOPT(05) = 3 PRGOPT(06) = 8 PRGOPT(07) = 10 PRGOPT(08) = 11 PRGOPT(09) = 16 PRGOPT(10) = 17 PRGOPT(11) = 21 PRGOPT(12) = 22 PRGOPT(13) = 24 PRGOPT(14) = 25 PRGOPT(15) = 27 PRGOPT(16) = 28 PRGOPT(17) = 35 PRGOPT(18) = 21 PRGOPT(19) = 51 PRGOPT(20) = 0 PRGOPT(21) = 1 call DSPLP(DUSRMT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV, BL, & ! ! LOOK FOR THE KNOWN BASIS AT THE SOLN., NOW IS ISOLN(*). ! BU, IND, INFO, PRIMAL, DUALS, IBASIS, WORK, LW, IWORK, LIW) DO I=1,MRELAS ISOLN(I) = PRGOPT(I+3) end do ipass = 1 DO 70 J=1,MRELAS DO I=1,MRELAS if ( ISOLN(I) == IBASIS(J)) GO TO 70 end do ipass = 0 GO TO 80 70 continue 80 if ( KPRINT >= 2) write (LUN, 99997) (ISOLN(I), IBASIS(I), & I=1,MRELAS) if ( KPRINT >= 2 .OR. (KPRINT == 1 .and. ipass /= 1)) & ! ! HERE IPASS=0 IF CODE FAILED QUICK CHECK; ! =1 IF CODE PASSED QUICK CHECK. ! call PASS (LUN, ICNT, IPASS) if ( KPRINT >= 1 .and. ipass /= 1) write (LUN,99999) if ( KPRINT >= 2 .and. ipass == 1) write (LUN,99998) return 99997 FORMAT (/' ISOLN IBASIS'/(2I10)) 99998 FORMAT (/' ************ DSPLP PASSED ALL TESTS ****************') 99999 FORMAT (/' ************ DSPLP FAILED SOME TESTS ***************') end !! DPNTCK !***PURPOSE Quick check for DPLINT, DPOLCF and DPOLVL !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (PNTCHK-S, DPNTCK-D) !***KEYWORDS QUICK CHECK !***AUTHOR Boland, W. Robert, (LANL) !***ROUTINES CALLED d1mach, DPLINT, DPOLCF, DPOLVL, NUMXER, XERCLR, ! XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 920212 DATE WRITTEN !***END PROLOGUE DPNTCK ! .. Scalar Arguments .. subroutine DPNTCK (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN double precision TOL, YF integer I, IERR, KONTRL, N, NERR ! .. Local Arrays .. LOGICAL FATAL ! .. External Functions .. double precision C(6), D(6), DCHK(6), W(12), X(6), XCHK(6), Y(6) double precision d1mach integer NUMXER ! .. External Subroutines .. EXTERNAL d1mach, NUMXER ! .. Intrinsic Functions .. EXTERNAL DPOLCF, DPLINT, DPOLVL, XERCLR, XGETF, XSETF ! .. Data statements .. INTRINSIC ABS, SQRT DATA X / 1.0D0, 2.0D0, 3.0D0, -1.0D0, -2.0D0, -3.0D0 / DATA Y / 0.0D0, 9.0D0, 64.0D0, 0.0D0, 9.0D0, 64.0D0 / DATA XCHK / 1.0D0, 0.0D0, -2.0D0, 0.0D0, 1.0D0, 0.0D0 / !***FIRST EXECUTABLE STATEMENT DPNTCK DATA DCHK / 1.0D0, 0.0D0, -4.0D0, 0.0D0, 24.0D0, 0.0D0 / ! ! Initialize variables for tests. ! if ( kprint >= 2) write (LUN,9000) TOL = SQRT(d1mach(4)) ipass = 1 ! ! Set up polynomial test. ! N = 6 call DPLINT (N, X, Y, C) ! ! Check to see if DPOLCF test passed. ! call DPOLCF (0.0D0, N, X, C, D, W) FATAL = .FALSE. DO I = 1,N if ( ABS(D(I)-XCHK(I)) > TOL ) then ipass = 0 FATAL = .TRUE. end if end do if ( FATAL ) then if ( kprint >= 2) write (LUN, 9010) 'FAILED', (D(I), I = 1,N) else if ( kprint >= 3) write (LUN, 9010) 'PASSED', (D(I), I = 1,N) end if ! ! Test DPOLVL. ! call DPOLVL (5, 0.0D0, YF, D, N, X, C, W, IERR) if ( ABS(DCHK(1)-YF) <= TOL ) then if ( kprint >= 3) write (LUN, 9020) 'PASSED', YF,(D(I),I=1,5) else ipass = 0 if ( kprint >= 2) write (LUN, 9020) 'FAILED', YF,(D(I),I=1,5) end if FATAL = .FALSE. DO I = 1,5 if ( ABS(DCHK(I+1)-D(I)) > TOL ) then ipass = 0 FATAL = .TRUE. end if end do ! ! Trigger 2 error conditions ! 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,9030) call DPLINT (0, X, Y, C) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr X(1) = -1.0D0 call DPLINT (N, X, Y, C) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr call XSETF (KONTRL) if ( FATAL ) then if ( kprint >= 2 ) then write (LUN, 9040) end if else if ( kprint >= 3 ) then write (LUN, 9050) end if end if if ( ipass == 1 .and. KPRINT >= 2) write (LUN,9080) if ( ipass == 0 .and. KPRINT >= 1) write (LUN,9090) return 9000 FORMAT ('1' / ' Test DPLINT, DPOLCF and DPOLVL') 9010 FORMAT (/ 'DPOLCF ', A, ' test' / & ' Taylor coefficients for the quintic should be' / & 6X, '1.000', 5X, '0.000', 4X, '-2.000', 5X, '0.000', 5X, & '1.000', 5X, '0.000' / & ' Taylor coefficients from DPOLCF are' / 1X, 6F10.3 /) 9020 FORMAT (' Derivative test ', A / & ' The derivatives of the polynomial at zero as ', & 'computed by DPOLVL are' / 1X, 6F10.3 /) 9030 FORMAT (/' 2 Error messages expected') 9040 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 9050 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED') 9080 FORMAT (/' ****************DPLINT PASSED ALL TESTS**************') 9090 FORMAT (/' ***************DPLINT FAILED SOME TESTS**************') end subroutine DPRIN (LUN, NUM1, KPRINT, IP, EXACT, RESULT, ABSERR, & !! DPRIN !***SUBSIDIARY !***PURPOSE Subsidiary to CDQAG, CDQAG, CDQAGI, CDQAGP, CDQAGS, CDQAWC, ! CDQAWF, CDQAWO, CDQAWS, and CDQNG. !***LIBRARY SLATEC !***AUTHOR Piessens, Robert ! Applied Mathematics and Programming Division ! K. U. Leuven ! de Doncker, Elise ! Applied Mathematics and Programming Division ! K. U. Leuven !***DESCRIPTION ! ! This program is called by the (double precision) Quadpack quick ! check routines for printing out their messages. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 811027 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 910627 Code completely rewritten. (WRB) !***END PROLOGUE DPRIN ! .. Scalar Arguments .. NEVAL, IERV, LIERV) double precision ABSERR, EXACT, RESULT ! .. Array Arguments .. integer IP, KPRINT, LIERV, LUN, NEVAL, NUM1 ! .. Local Scalars .. integer IERV(*) double precision ERROR ! .. Intrinsic Functions .. integer IER, K !***FIRST EXECUTABLE STATEMENT DPRIN INTRINSIC ABS IER = IERV(1) ERROR = ABS(EXACT-RESULT) if ( kprint >= 2 ) then if ( IP == 1 ) then ! ! Write PASS message. ! if ( kprint >= 3 ) then write (UNIT=LUN, FMT=9000) NUM1 end if ! ! Write failure messages. ! else write (UNIT=LUN, FMT=9010) NUM1 if ( NUM1 == 0) write (UNIT=LUN, FMT=9020) if ( NUM1 > 0) write (UNIT=LUN, FMT=9030) NUM1 if ( LIERV > 1) write (UNIT=LUN, FMT=9040) (IERV(K), & K=2,LIERV) if ( NUM1 == 6) write (UNIT=LUN, FMT=9050) write (UNIT=LUN, FMT=9060) write (UNIT=LUN, FMT=9070) if ( NUM1 /= 5 ) then write (UNIT=LUN, FMT=9080) EXACT,RESULT,ERROR,ABSERR,IER, & NEVAL else write (LUN,FMT=9090) RESULT,ABSERR,IER,NEVAL end if end if end if return 9000 FORMAT (' TEST ON IER = ', I2, ' PASSED') 9010 FORMAT (' TEST ON IER = ', I1, ' FAILED.') 9020 FORMAT (' WE MUST HAVE IER = 0, ERROR <= ABSERR AND ABSERR.LE', & '.MAX(EPSABS,EPSREL*ABS(EXACT))') 9030 FORMAT (' WE MUST HAVE IER = ', I1) 9040 FORMAT (' OR IER = ', 8(I1,2X)) 9050 FORMAT (' RESULT, ABSERR, NEVAL AND EVENTUALLY LAST SHOULD BE', & ' ZERO') 9060 FORMAT (' WE HAVE ') 9070 FORMAT (7X, 'EXACT', 11X, 'RESULT', 6X, 'ERROR', 4X, 'ABSERR', & 4X, 'IER NEVAL', /, ' ', 42X, & '(EST.ERR.)(FLAG)(NO F-EVAL)') 9080 FORMAT (' ', 2(D15.7,1X), 2(D9.2,1X), I4, 4X, I6) 9090 FORMAT (5X, 'INFINITY', 4X, D15.7, 11X, D9.2, I5, 4X, I6) end subroutine DQC36J (LUN, KPRINT, IPASS) !*****************************************************************************80 ! !! DQC36J !***SUBSIDIARY !***PURPOSE THIS IS A QUICK CHECK PROGRAM FOR THE SUBROUTINES DRC3JJ, ! DRC3JM, AND DRC6J, WHICH CALCULATE THE WIGNER COEFFICIENTS, ! 3J AND 6J. !***LIBRARY SLATEC !***CATEGORY C19 !***TYPE DOUBLE PRECISION (QC36J-S, DQC36J-D) !***KEYWORDS 3J COEFFICIENTS, 3J SYMBOLS, 6J COEFFICIENTS, 6J SYMBOLS, ! CLEBSCH-GORDAN COEFFICIENTS, QUICK CHECK, ! RACAH COEFFICIENTS, VECTOR ADDITION COEFFICIENTS, ! WIGNER COEFFICIENTS !***AUTHOR LOZIER, DANIEL W., (NIST) ! MCCLAIN, MARJORIE A., (NIST) ! SMITH, JOHN M., (NIST AND GEORGE MASON UNIVERSITY) !***REFERENCES MESSIAH, ALBERT., QUANTUM MECHANICS, VOLUME II, ! NORTH-HOLLAND PUBLISHING COMPANY, 1963. !***ROUTINES CALLED d1mach, DRC3JJ, DRC3JM, DRC6J, NUMXER, XERCLR, ! XSETF !***REVISION HISTORY (YYMMDD) ! 891129 DATE WRITTEN ! 910415 Mixed type expressions eliminated; precision of output ! formats made uniform for all tests; detail added to output ! when KPRINT=2 and a test fails; name of quick check added ! to output when KPRINT=3 or KPRINT=2 and a test fails; some ! output formats modified for clarity or adherence to SLATEC ! guidelines. These changes were done by D. W. Lozier. ! 930115 Replaced direct calculation of 3j-6j symbols in tests 1, 2, ! and 4 with values stored in data statements. This involved ! removing all calls to subroutine DRACAH. These changes were ! made by M. McClain. !***END PROLOGUE DQC36J ! integer ll1 integer LUN integer mm2 integer KPRINT, IPASS CHARACTER STRING*36, FMT*30, FMT2*13 integer IPASS1, IPASS2, IPASS3, IPASS4, IPASS5, NDIM, IER, INDEX, & I, FIRST, LAST, NSIG, NUMXER, NERR, IERJJ, IERJM PARAMETER(NDIM=15) double precision TOL, L1, L2, L3, M1, M2, M3, L1MIN, L1MAX, M2MIN, & M2MAX, DIFF(NDIM), d1mach, X, JJVAL, JMVAL, THRCOF(NDIM), & SIXCOF(NDIM), R3JJ(8), R3JM(14), R6J(15) DATA R3JJ / 2.7888667551135851599272400859506249646427D-1, & -9.5346258924559231544677592152721599861388D-2, & -6.7419986246324208624649067643642846008908D-2, & 1.5331103516796664129653641995122585402552D-1, & -1.5644655469368596972508355755184909201031D-1, & 1.0994504121565505107947893271429777505797D-1, & -5.5362356931317194333395729256559987745156D-2, & 1.7998354511377858329814092962590761537262D-2/ DATA R3JM / 2.0915897328861524261384476677886072045904D-2, & 8.5375655532152472212727551895879778672762D-2, & 9.0829537086869251694343772675676175068677D-2, & -3.8905437784649939169989036459327065796765D-2, & -6.6373497016568063569146501153397525003444D-2, & 6.4952404052838939503061387831391216401903D-2, & 2.1589431059540375939250708046202926313913D-2, & -7.7891271178523921999229618972588887261359D-2, & 3.5976437105954340188005810512211794384411D-2, & 5.4730150002126342307937096038252488407360D-2, & -7.5967866595676151462927617736745078548338D-2, & -2.1922444553989211377558215380002910257762D-2, & 1.0116774428077220242411199686231560525497D-1, & 7.3482572624471970469595137204530687381176D-2/ DATA R6J / 3.4909051383732997774596981092927782159095D-2, & -3.7430250396597916085929064401358002747549D-2, & 1.8908663909595601841537964135129184202064D-2, & 7.3424482549286434570947151839589351100581D-3, & -2.3589351850817944585847816357296508528608D-2, & 1.9134769552154365200026782557432864615918D-2, & 1.2880173977241722084434864685591278730958D-3, & -1.9300183662905265397749119277519305417805D-2, & 1.6773059493828887697413611251392749162229D-2, & 5.5011472748509487167380502058890639729979D-3, & -2.1354397908968309742136976853078409839580D-2, & 3.4603644514353873082775312319159137043869D-3, & 2.5209500547955845860442730268272167527589D-2, & 1.4839905612217133028540464232557124565509D-2, & 2.7085776806331855972407001825016114677027D-3/ ! !***FIRST EXECUTABLE STATEMENT DQC36J ! ! INITIALIZATION OF TESTS ! TOL=100.0D0*d1mach(3) if ( KPRINT >= 2 ) then write (LUN,*)' THIS IS DQC36J, A TEST PROGRAM FOR THE ' // & 'DOUBLE PRECISION 3J6J PACKAGE.' write (LUN,*)' AN EXPLANATION OF THE VARIOUS ' // & 'TESTS CAN BE FOUND IN THE PROGRAM COMMENTS.' write (LUN,*) end if ! ! FIND NUMBER OF SIGNIFICANT FIGURES FOR FORMATTING ! X=1.D0/3.D0 write (STRING,100)X 100 FORMAT(F35.25) DO I=1,35 if ( STRING(I:I) == '3' ) then FIRST=I exit end if end do LAST = 36 DO I=FIRST,35 if ( STRING(I:I) /= '3' ) then LAST=I-1 exit end if end do NSIG=LAST-FIRST+1 FMT(1:16)='(1X,F5.1,T8,G35.' write (FMT(17:18),'(I2)')NSIG FMT(19:27)=',T45,G35.' write (FMT(28:29),'(I2)')NSIG FMT(30:30)=')' FMT2(1:10)='(1X,A,G35.' write (FMT2(11:12),'(I2)')NSIG ! ! TEST 1: COMPARE DRC3JJ VALUES WITH FORMULA ! FMT2(13:13)=')' IPASS1=1 L2=4.5D0 L3=3.5D0 M2=-3.5D0 M3=2.5D0 call DRC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IER) if ( IER /= 0 ) then IPASS1=0 else DO LL1 = int ( L1MIN ), int ( L1MAX ) INDEX = LL1 - INT ( L1MIN ) + 1 M1=1.0D0 DIFF(INDEX)=ABS(THRCOF(INDEX)-R3JJ(INDEX)) if ( DIFF(INDEX) > ABS(R3JJ(INDEX))*TOL)IPASS1=0 end do end if if ( KPRINT >= 3 .OR. (KPRINT == 2 .and. IPASS1 == 0) ) then write (LUN,*)' TEST 1, RECURRENCE IN L1, COMPARE VALUES OF 3J ', & 'CALCULATED BY DRC3JJ TO' write (LUN,*)' VALUES CALCULATED BY EXPLICIT FORMULA FROM ', & 'MESSIAH''S QUANTUM MECHANICS' write (LUN,600)L2,L3 600 FORMAT(' L2 = ',F5.1,' L3 = ',F5.1) write (LUN,700)M1,M2,M3 700 FORMAT(' M1 = ',F5.1,' M2 = ',F5.1,' M3 = ',F5.1) if ( IER /= 0 ) then write (LUN,*)' ERROR RETURNED FROM SUBROUTINE ', & 'DRC3JJ: IER =',IER else write (LUN,800) 800 FORMAT(' L1',T31,'DRC3JJ VALUE',T67,'FORMULA VALUE') DO LL1 = int ( L1MIN ), int ( L1MAX ) L1 = dble ( LL1 ) INDEX = LL1 - INT ( L1MIN ) + 1 write (LUN,FMT)L1,THRCOF(INDEX),R3JJ(INDEX) if ( DIFF(INDEX) > ABS(R3JJ(INDEX))*TOL ) then write (LUN,'(1X,A,F5.1)')'DIFFERENCE EXCEEDS ERROR '// & 'TOLERANCE FOR L1 =',L1 end if end do end if end if if ( IPASS1 == 0 ) then if ( KPRINT >= 1 ) then write (LUN,*)' ***** ***** TEST 1 FAILED ***** *****' write (LUN,*) end if else if ( KPRINT >= 2 ) then write (LUN,*)' ***** ***** TEST 1 PASSED ***** *****' write (LUN,*) end if end if ! ! TEST 2: COMPARE DRC3JM VALUES WITH FORMULA ! IPASS2=1 L1=8.0D0 L2=7.5D0 L3=6.5D0 M1=1.0D0 call DRC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) if ( IER /= 0 ) then IPASS2=0 else DO MM2 = int ( M2MIN ), int ( M2MAX ) M2 = real ( MM2 ) INDEX = MM2 - INT ( M2MIN ) + 1 M3 = - M1 - M2 DIFF(INDEX)=ABS(THRCOF(INDEX)-R3JM(INDEX)) if ( DIFF(INDEX) > ABS(R3JM(INDEX))*TOL)IPASS2=0 end do end if if ( KPRINT >= 3 .OR. (KPRINT == 2 .and. IPASS2 == 0) ) then write (LUN,*)' TEST 2, RECURRENCE IN M2, COMPARE VALUES OF 3J ', & 'CALCULATED BY DRC3JM TO' write (LUN,*)' VALUES CALCULATED BY EXPLICIT FORMULA FROM ', & 'MESSIAH''S QUANTUM MECHANICS' write (LUN,1000)L1,L2,L3 1000 FORMAT(' L1 = ',F5.1,' L2 = ',F5.1,' L3 = ',F5.1) write (LUN,1100)M1 1100 FORMAT(' M1 = ',F5.1,' M3 = -(M1+M2)') if ( IER /= 0 ) then write (LUN,*)' ERROR RETURNED FROM SUBROUTINE ', & 'DRC3JM: IER =',IER else write (LUN,1200) 1200 FORMAT(' M2',T31,'DRC3JM VALUE',T67,'FORMULA VALUE') DO MM2 = int ( M2MIN ), int ( M2MAX ) INDEX = MM2 - INT ( M2MIN ) + 1 M2 = dble ( MM2 ) write (LUN,FMT)M2,THRCOF(INDEX),R3JM(INDEX) if ( DIFF(INDEX) > ABS(R3JM(INDEX))*TOL ) then write (LUN,'(1X,A,F5.1)')'DIFFERENCE EXCEEDS ERROR '// & 'TOLERANCE FOR M2 =',M2 end if end do end if end if if ( IPASS2 == 0 ) then if ( KPRINT >= 1 ) then write (LUN,*)' ***** ***** TEST 2 FAILED ***** *****' write (LUN,*) end if else if ( KPRINT >= 2 ) then write (LUN,*)' ***** ***** TEST 2 PASSED ***** *****' write (LUN,*) end if end if ! ! TEST3: COMPARE COMMON VALUE OF DRC3JJ AND DRC3JM ! IPASS3=1 L1=100.0D0 L2=2.0D0 L3=100.0D0 M1=-10.0D0 M2=0.0D0 M3=10.0D0 call DRC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IERJJ) JJVAL=THRCOF(3) call DRC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IERJM) JMVAL=THRCOF(3) if ( IERJJ /= 0 .OR. IERJM /= 0 ) then IPASS3=0 else DIFF(1)=ABS(JJVAL-JMVAL) if ( DIFF(1) > 0.5*ABS(JJVAL+JMVAL)*TOL)IPASS3=0 end if if ( KPRINT >= 3 .OR. (KPRINT == 2 .and. IPASS3 == 0) ) then write (LUN,*)' TEST 3, COMPARE A COMMON VALUE CALCULATED BY ', & 'BOTH DRC3JJ AND DRC3JM' write (LUN,*)' L1 = 100.0 L2 = 2.0 L3 = 100.0' write (LUN,*)' M1 = -10.0 M2 = 0.0 M3 = 10.0' if ( IERJJ /= 0 ) then write (LUN,*)' ERROR RETURNED FROM SUBROUTINE ', & 'DRC3JJ: IER =',IERJJ elseif ( IERJM /= 0 ) then write (LUN,*)' ERROR RETURNED FROM SUBROUTINE ', & 'DRC3JM: IER =',IERJM else write (LUN,FMT2)'DRC3JJ VALUE =',JJVAL write (LUN,FMT2)'DRC3JM VALUE =',JMVAL if ( DIFF(1) > 0.5*ABS(JJVAL+JMVAL)*TOL ) then write (LUN,'(1X,A)')'DIFFERENCE EXCEEDS ERROR TOLERANCE' end if end if end if if ( IPASS3 == 0 ) then if ( KPRINT >= 1 ) then write (LUN,*)' ***** ***** TEST 3 FAILED ***** *****' write (LUN,*) end if else if ( KPRINT >= 2 ) then write (LUN,*)' ***** ***** TEST 3 PASSED ***** *****' write (LUN,*) end if end if ! ! TEST 4: COMPARE DRC6J VALUES WITH FORMULA ! IPASS4=1 L2=8.0D0 L3=7.0D0 M1=6.5D0 M2=7.5D0 M3=7.5D0 call DRC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) if ( IER /= 0 ) then IPASS4=0 else DO LL1 = int ( L1MIN ), int ( L1MAX ) INDEX= LL1 - INT ( L1MIN ) + 1 DIFF(INDEX)=ABS(SIXCOF(INDEX)-R6J(INDEX)) if ( DIFF(INDEX) > ABS(R6J(INDEX))*TOL)IPASS4=0 end do end if if ( KPRINT >= 3 .OR. (KPRINT == 2 .and. IPASS4 == 0) ) then write (LUN,*)' TEST 4, RECURRENCE IN L1, COMPARE VALUES OF 6J ', & 'CALCULATED BY DRC6J TO' write (LUN,*)' VALUES CALCULATED BY EXPLICIT FORMULA FROM ', & 'MESSIAH''S QUANTUM MECHANICS' write (LUN,600)L2,L3 write (LUN,700)M1,M2,M3 if ( IER /= 0 ) then write (LUN,*)' ERROR RETURNED FROM SUBROUTINE ', & 'DRC6J: IER =',IER else write (LUN,1320) 1320 FORMAT(' L1',T32,'DRC6J VALUE',T67,'FORMULA VALUE') DO LL1 = int ( L1MIN ), int ( L1MAX ) INDEX = LL1 - INT ( L1MIN ) + 1 L1 = dble ( LL1 ) write (LUN,FMT) L1,SIXCOF(INDEX),R6J(INDEX) if ( DIFF(INDEX) > ABS(R6J(INDEX))*TOL ) then write (LUN,'(1X,A,F5.1)')'DIFFERENCE EXCEEDS ERROR '// & 'TOLERANCE FOR L1 =',L1 end if end do end if end if if ( IPASS4 == 0 ) then if ( KPRINT >= 1 ) then write (LUN,*)' ***** ***** TEST 4 FAILED ***** *****' write (LUN,*) end if else if ( KPRINT >= 2 ) then write (LUN,*)' ***** ***** TEST 4 PASSED ***** *****' write (LUN,*) end if end if ! ! TEST 5: CHECK INVALID INPUT ! IPASS5=1 if ( kprint <= 2 ) then call xsetf ( 0 ) else call xsetf ( -1 ) end if ! ! DRC3JJ: L2-ABS(M2) OR L3-ABS(M3) LESS THAN ZERO (IER=1) ! if ( KPRINT >= 3)WRITE(LUN,*)' TEST 5, CHECK FOR PROPER HANDLING ', & 'OF INVALID INPUT' L2=2.0D0 L3=100.0D0 M1=-6.0D0 M2=-4.0D0 M3=10.0D0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DRC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IER) ! --- DRC3JJ: L2+ABS(M2) OR L3+ABS(M3) NOT INTEGER (IER=2) if ( NUMXER(NERR) /= IER)IPASS5=0 L2=2.0D0 L3=99.5D0 M1=-10.0D0 M2=0.0D0 M3=10.0D0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DRC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IER) ! --- DRC3JJ: L1MAX-L1MIN NOT INTEGER (IER=3) if ( NUMXER(NERR) /= IER)IPASS5=0 L2=3.2D0 L3=4.5D0 M1=-1.3D0 M2=0.8D0 M3=0.5D0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DRC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IER) ! --- DRC3JJ: L1MIN GREATER THAN L1MAX (IER=4) ! (NO TEST -- THIS ERROR SHOULD NEVER OCCUR) ! --- DRC3JJ: DIMENSION OF THRCOF TOO SMALL (IER=5) if ( NUMXER(NERR) /= IER)IPASS5=0 L2=10.0D0 L3=150.0D0 M1=-10.0D0 M2=0.0D0 M3=10.0D0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DRC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IER) ! --- DRC3JM: L1-ABS(M1) < ZERO OR L1+ABS(M1) NOT INTEGER (IER=1) if ( NUMXER(NERR) /= IER)IPASS5=0 L1=100.0D0 L2=2.0D0 L3=100.0D0 M1=150.0D0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DRC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) ! --- DRC3JM: L1, L2, L3 DO NOT SATISFY TRIANGULAR CONDITION (IER=2) if ( NUMXER(NERR) /= IER)IPASS5=0 L1=20.0D0 L2=5.0D0 L3=10.0D0 M1=-10.0D0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DRC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) ! --- DRC3JM: L1+L2+L3 NOT INTEGER (IER=3) if ( NUMXER(NERR) /= IER)IPASS5=0 L1=1.0D0 L2=1.3D0 L3=1.5D0 M1=0.0D0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DRC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) ! --- DRC3JM: M2MAX-M2MIN NOT INTEGER (IER=4) if ( NUMXER(NERR) /= IER)IPASS5=0 L1=1.0D0 L2=1.3D0 L3=1.7D0 M1=0.0D0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DRC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) ! --- DRC3JM: M2MIN GREATER THAN M2MAX (IER=5) ! (NO TEST -- THIS ERROR SHOULD NEVER OCCUR) ! --- DRC3JM: DIMENSION OF THRCOF TOO SMALL (IER=6) if ( NUMXER(NERR) /= IER)IPASS5=0 L1=100.0D0 L2=10.0D0 L3=110.0D0 M1=-10.0D0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DRC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) ! --- DRC6J: L2+L3+L5+L6 OR L4+L2+L6 NOT INTEGER (IER=1) if ( NUMXER(NERR) /= IER)IPASS5=0 L2=0.5D0 L3=1.0D0 M1=0.5D0 M2=2.0D0 M3=3.0D0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DRC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) ! --- DRC6J: L4, L2, L6 TRIANGULAR CONDITION NOT SATISFIED (IER=2) if ( NUMXER(NERR) /= IER)IPASS5=0 L2=1.0D0 L3=3.0D0 M1=5.0D0 M2=6.0D0 M3=2.0D0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DRC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) ! --- DRC6J: L4, L5, L3 TRIANGULAR CONDITION NOT SATISFIED (IER=3) if ( NUMXER(NERR) /= IER)IPASS5=0 L2=4.0D0 L3=1.0D0 M1=5.0D0 M2=3.0D0 M3=2.0D0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DRC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) ! --- DRC6J: L1MAX-L1MIN NOT INTEGER (IER=4) if ( NUMXER(NERR) /= IER)IPASS5=0 L2=0.9D0 L3=0.5D0 M1=0.9D0 M2=0.4D0 M3=0.2D0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DRC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) ! --- DRC6J: L1MIN GREATER THAN L1MAX (IER=5) ! (NO TEST -- THIS ERROR SHOULD NEVER OCCUR) ! --- DRC6J: DIMENSION OF SIXCOF TOO SMALL (IER=6) if ( NUMXER(NERR) /= IER)IPASS5=0 L2=50.0D0 L3=25.0D0 M1=15.0D0 M2=30.0D0 M3=40.0D0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DRC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) if ( NUMXER(NERR) /= IER)IPASS5=0 if ( IPASS5 == 0 ) then if ( KPRINT >= 1 ) then write (LUN,*)' ***** ***** TEST 5 FAILED ***** *****' write (LUN,*) end if else if ( KPRINT >= 2 ) then write (LUN,*)' ***** ***** TEST 5 PASSED ***** *****' write (LUN,*) end if end if if ( (IPASS1 == 0).OR.(IPASS2 == 0).OR.(IPASS3 == 0).OR. & (IPASS4 == 0).OR.(IPASS5 == 0) ) then IPASS=0 if ( KPRINT >= 1)WRITE(LUN,1500) else IPASS=1 if ( KPRINT >= 2)WRITE(LUN,1600) end if 1500 FORMAT(' ***** DQC36J FAILED SOME TESTS *****') 1600 FORMAT(' ***** DQC36J PASSED ALL TESTS *****') return end !! DQCGLS !***PURPOSE Quick check for DGLSS. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (QCGLSS-S, DQCGLS-D) !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! QUICK CHECK SUBROUTINE DQCGLS TESTS THE EXECUTION ! OF THE GENERAL LINEAR SYSTEM SOLVER, DGLSS . THE ! DGLSS SUBROUTINE PACKAGE WAS WRITTEN BY T. MANTEUFFEL ! (LANL). ! ! A TITLE LINE AND A SUMMARY LINE ARE ALWAYS OUTPUTTED ! BY DQCGLS. THE SUMMARY LINE GIVES A COUNT OF THE ! NUMBER OF PROBLEMS DETECTED DURING THE TEST. ! ! THE REAL QUANTITIES FOR THE COMPUTED SOLUTION VECTOR ! X AND THE CORRESPONDING RNORM ARE COMPARED AGAINST ! STORED VALUES. DISAGREEMENT OCCURS IF A DIFFERENCE ! IS SQRT(d1mach(4) OR MORE. THE RETURNED VALUE (INTEGER) ! OF INFO IS ALSO CHECKED. FOUR CASES ARE RUN, TWO ! INVOLVING LLSIA AND TWO INVOLVING ULSIA . ! ! DQCGLS REQUIRES NO INPUT ARGUMENTS. ON RETURN, NERR ! (INTEGER TYPE) CONTAINS THE COUNT OF THE NUMBER OF ! PROBLEMS DETECTED BY QCGLSS . ! !***ROUTINES CALLED d1mach, DGLSS !***REVISION HISTORY (YYMMDD) ! 811026 DATE WRITTEN ! 850601 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if, cleaned up FORMATs, ! including removing an illegal character from column 1, and ! editorial changes. (RWC) !***END PROLOGUE DQCGLS ! subroutine DQCGLS (LUN, KPRINT, IPASS) IMPLICIT DOUBLE PRECISION (A-H,O-Z) dimension AA(4,4,2),A(4,4),BB(4,2),B(4),XX(4,4) dimension WORK(50) CHARACTER*1 LIST(2) integer INF(4),NERR,KPROG,KCASE integer IWORK(20),INFO,LUN DATA AA/1.D0,.5D0,1.D0,.25D0,0.D0,2.D0,0.D0,1.D0,2.D0,-1.D0, & 1.D0,0.D0,0.D0,0.D0,0.D0,0.D0,1.D0,2.D0,-1.D0,0.D0,0.D0,1.D0, & 2.D0,0.D0,-1.D0,0.D0,1.D0,0.D0,1.D0,0.D0,1.D0,0.D0/ DATA BB/3.D0,1.5D0,2.D0,1.25D0,1.D0,3.D0,3.D0,0.D0/ DATA XX/.9999999999999787D0,1.000000000000007D0, & 1.000000000000007D0,0.D0,.8095238095238102D0, & 1.047619047619044D0,1.095238095238081D0,0.D0, & .7777777777777857D0,1.444444444444429D0,.3333333333333393D0, & .5555555555555500D0, & .3333333333333321D0,0.0D0,-.3333333333333286D0, & .3333333333333286D0/ DATA INF/0,1,0,2/ !***FIRST EXECUTABLE STATEMENT DQCGLS DATA LIST/'L', 'U'/ INFO = 0 NERR = 0 R = max ( SQRT(d1mach(4)),1.D-12) if ( KPRINT >= 2) WRITE(LUN,800) DO 60 KPROG=1,2 ! ! FORM BASIC MATRIX A AND VECTOR B . (CASE 1) ! DO 50 KCASE=1,2 DO 10 I=1,4 DO J=1,4 A(I,J) = AA(I,J,KPROG) end do B(I) = BB(I,KPROG) ! ! MAKE 3 ROWS IDENTICAL FOR CASE 2. ! 10 continue if ( KCASE /= 1 ) then DO I=2,3 DO J=1,4 A(I,J) = A(1,J) end do B(I) = B(1) end do ! ! SOLVE FOR VECTOR X . ! end if INFO = 0 if ( KPROG == 1) call DGLSS(A,4,4,3,B,4,1,RNORM,WORK,50, & IWORK,20,INFO) if ( KPROG == 2) call DGLSS(A,4,3,4,B,4,1,RNORM,WORK,50, & IWORK,20,INFO) ! ! TEST COMPUTED X , RNORM , AND INFO . ! KK = 2*(KPROG - 1) + KCASE DELMAX = 0.0D0 DO I=1,4 DELX = ABS(B(I)-XX(I,KK)) DELMAX = max ( DELMAX,DELX) end do if ( KPRINT >= 3) write (LUN,701) LIST(KPROG),KCASE,DELMAX if ( DELMAX >= R ) then NERR = NERR + 1 if ( KPRINT >= 2) WRITE(LUN,801) LIST(KPROG),KCASE,DELMAX end if if ( KPRINT >= 3) write (LUN,702) LIST(KPROG),KCASE,RNORM if ( RNORM >= R ) then NERR = NERR + 1 if ( KPRINT >= 2) write (LUN,802) LIST(KPROG),KCASE,RNORM end if if ( KPRINT >= 3) write (LUN,703) LIST(KPROG),KCASE,INFO, & INF(KK) if ( INFO /= INF(KK) ) then NERR = NERR + 1 if ( KPRINT >= 2) write (LUN,803) LIST(KPROG),KCASE,INFO, & INF(KK) end if 50 continue ! ! SUMMARY PRINT ! 60 continue IPASS=0 if ( NERR == 0) IPASS=1 if ( NERR /= 0 .and. kprint /= 0) write (LUN,804) NERR if ( NERR == 0 .and. kprint > 1) write (LUN,805) ! return 703 FORMAT (3X, A, 'LSIA, CASE ', I1, '. INFO=', I1, ' (SHOULD = ', & I1, ')'/) 804 FORMAT (/' **** DQCGLS DETECTED A TOTAL OF ', I2, & ' PROBLEMS WITH DGLSS. ****'/) 805 FORMAT (' DQCGLS DETECTED NO PROBLEMS WITH DGLSS.'/) 801 FORMAT (' PROBLEM WITH ', A, 'LSIA, CASE ', I1, & '. MAX ABS ERROR OF', D11.4/) 800 FORMAT(/' * DQCGLS - QUICK CHECK FOR DGLSS (DLLSIA AND DULSIA)'/) 701 FORMAT (3X, A, 'LSIA, CASE ', I1, '. MAX ABS ERROR OF', D11.4/) 702 FORMAT (3X, A, 'LSIA, CASE ', I1, '. RNORM IS ', D11.4/) 802 FORMAT (' PROBLEM WITH ', A, 'LSIA, CASE ', I1, & '. RNORM (TOO LARGE) IS', D11.4/) 803 FORMAT (' PROBLEM WITH ', A, 'LSIA, CASE ', I1, '. INFO=', I1, & ' (SHOULD = ', I1, ')'/) end !! DQCK !***PURPOSE Quick check for DPOFS AND DNBFS. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! QUICK CHECK SUBROUTINE DQCK TESTS THE EXECUTION OF THE ! SLATEC SUBROUTINES DPOFS AND DNBFS. ! A TITLE LINE AND A SUMMARY LINE ARE ALWAYS OUTPUTTED. ! ! THE SUMMARY LINE GIVES A COUNT OF THE NUMBER OF ! PROBLEMS ENCOUNTERED IN THE TEST IF ANY EXIST. DQCK ! CHECKS COMPUTED VS. EXACT SOLUTIONS TO AGREE TO ! WITHIN 0.8 TIMES THE WORD LENGTH OF THE COMPUTER ! (1.6 IF DOUBLE PRECISION) FOR CASE 1. DQCK ALSO ! TESTS ERROR HANDLING BY THE SUBROUTINE (CALLS TO ! XERMSG (DQCK SETS IFLAG/KONTRL TO 0)) ! USING A SINGULAR MATRIX FOR CASE 2. EACH EXECUTION ! PROBLEM DETECTED BY DQCK RESULTS IN AN ADDITIONAL ! EXPLANATORY LINE OF OUTPUT. ! ! DQCK REQUIRES NO INPUT ARGUMENTS. ! ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT ! OF ALL PROBLEMS DETECTED BY DQCK. ! !***ROUTINES CALLED d1mach, DNBFS, DPOFS !***REVISION HISTORY (YYMMDD) ! 801002 DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901009 Restructured using IF-THEN-else-end if, cleaned up FORMATs, ! including removing an illegal character from column 1, and ! editorial changes. (RWC) !***END PROLOGUE DQCK subroutine DQCK (LUN, KPRINT, NERR) double precision A(4,4),AT(5,4),ABE(5,7),ABET(5,7),B(4),BT(4), & C(4),WORK(35),SIGN,d1mach REAL R,DELX,DELMAX CHARACTER*4 LIST(2) integer LDA,N,ML,MU,IND,IWORK(4),NERR,I,J,J1,J2,JD,MLP,K,KCASE, & KPROG DATA A/5.0D0,4.0D0,1.0D0,1.0D0,4.0D0,5.0D0,1.0D0,1.0D0, & 1.0D0,1.0D0,4.0D0,2.0D0,1.0D0,1.0D0,2.0D0,4.0D0/ !***FIRST EXECUTABLE STATEMENT DQCK DATA LIST/'POFS', 'NBFS'/ if ( KPRINT >= 3) write (LUN,800) LDA = 5 N = 4 ML = 2 MU = 1 JD = 2*ML+MU+1 NERR = 0 ! ! COMPUTE C VECTOR. ! R = d1mach(4)**0.8E0 SIGN = 1.0D0 DO I=1,N C(I) = SIGN/I SIGN = -SIGN end do ! ! CASE 1 FOR WELL-CONDITIONED MATRIX, CASE 2 FOR SINGULAR MATRIX. ! DO 170 KCASE=1,2 ! ! SET VECTOR B TO ZERO. ! DO 140 KPROG=1,2 B(1:N) = 0.0D0 ! ! FORM VECTOR B FOR NON-BANDED. ! if ( KPROG == 1 ) then DO 13 I=1,N DO 12 J=1,N B(I) = B(I)+A(I,J)*C(J) 12 continue 13 continue ! ! FORM ABE(NB ARRAY) FROM MATRIX A ! AND FORM VECTOR B FOR BANDED. ! else ABE(1:N,1:JD) = 0.0D0 MLP = ML+1 DO I=1,N J1 = max ( 1,I-ML) J2 = min ( N,I+MU) DO J=J1,J2 K = J-I+MLP ABE(I,K) = A(I,J) B(I) = B(I)+(A(I,J)*C(J)) end do end do end if ! ! FORM BT FROM B, AT FROM A, AND ABET FROM ABE. ! BT(1:N) = B(1:N) AT(1:N,1:N) = A(1:N,1:N) ABET(1:N,1:JD) = ABE(1:N,1:JD) ! ! MAKE AT AND ABET SINGULAR FOR CASE = 2 ! if ( KCASE == 2 ) then AT(1,1:N) = 0.0D0 ABET(1,1:JD) = 0.0D0 end if ! ! SOLVE FOR X ! if ( KPROG == 1) call DPOFS (AT,LDA,N,BT,1,IND,WORK) if ( KPROG == 2) call DNBFS (ABET,LDA,N,ML,MU,BT,1,IND,WORK, & ! ! COMPARE EXACT AND COMPUTED SOLUTIONS FOR CASE 1 ! IWORK) if ( KCASE == 1 ) then DELMAX = 0.0E0 DO I=1,N DELX = ABS(BT(I)-C(I)) DELMAX = max ( DELMAX,DELX) end do if ( R <= DELMAX ) then NERR = NERR+1 write (LUN,801) LIST(KPROG),KCASE,DELMAX end if ! ! CHECK CONTROL FOR SINGULAR MATRIX FOR CASE 2 ! else if ( IND /= -4 ) then NERR = NERR+1 write (LUN,802) LIST(KPROG),KCASE,IND end