program main !*****************************************************************************80 ! !! slatec_test() tests slatec(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 February 2023 ! ! Local: ! ! 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 call timestamp ( ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'slatec_test():' write ( *, '(a)' ) ' FORTRAN90 version' write ( *, '(a)' ) ' Test slatec().' kprint = 0 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 ) 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 ) ! ! Terminate. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'slatec_test():' write ( *, '(a)' ) ' Normal end of execution.' write ( *, '(a)' ) ' ' call timestamp ( ) stop 0 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 February 2023 ! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 February 2023 ! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 February 2023 ! ! 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 if ( .false. ) then call QXBVSP ( lun, kprint, ipass ) else ipass = 1 write ( *, * ) '' write ( *, * ) 'test43():' write ( *, * ) ' Call to qxbvsp cancelled!' write ( *, * ) ' External functions fmat, gvec, uivp, uvec not supplied.' end if ! ! Write PASS or FAIL message ! if ( ipass == 0) then nfail = nfail + 1 end if 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 February 2023 ! ! 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 if ( .false. ) then call QXDBVS ( lun, kprint, ipass ) else ipass = 1 write ( *, * ) '' write ( *, * ) 'test44():' write ( *, * ) ' Call to qxdbvs cancelled!' write ( *, * ) ' External functions dfmat, dgvec, duivp, duvec not supplied.' end if ! ! 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 l1 = l1min index = 1 do while ( l1 <= l1max ) M1=1.0D0 DIFF(INDEX)=ABS(THRCOF(INDEX)-R3JJ(INDEX)) if ( DIFF(INDEX) > ABS(R3JJ(INDEX))*TOL) then IPASS1=0 end if l1 = l1 + 1.0D+00 index = index + 1 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') l1 = l1min index = 1 do while ( l1 <= l1max ) 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 l1 = l1 + 1.0D+00 index = index + 1 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 m2 = m2min index = 1 do while ( m2 <= m2max ) M3 = - M1 - M2 DIFF(INDEX)=ABS(THRCOF(INDEX)-R3JM(INDEX)) if ( DIFF(INDEX) > ABS(R3JM(INDEX))*TOL) then IPASS2=0 end if m2 = m2 + 1.0D+00 index = index + 1 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') m2 = m2min index = 1 do while ( m2 <= m2max ) 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 m2 = m2 + 1.0D+00 index = index + 1 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 l1 = l1min index = 1 do while ( l1 <= l1max ) DIFF(INDEX)=ABS(SIXCOF(INDEX)-R6J(INDEX)) if ( DIFF(INDEX) > ABS(R6J(INDEX))*TOL)IPASS4=0 l1 = l1 + 1.0D+00 index = index + 1 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') l1 = l1min index = index + 1 do while ( l1 <= l1max ) 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 l1 = l1 + 1.0D+00 index = index + 1 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)then WRITE(LUN,*)' TEST 5, CHECK FOR PROPER HANDLING OF INVALID INPUT' end if 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 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 (/' * DQCK - QUICK CHECK FOR DPOFS AND DNBFS'/) 801 FORMAT (' PROBLEM WITH D', A, ', CASE ', I1, & '. MAX ABS ERROR OF', E11.4/) 802 FORMAT (' PROBLEM WITH D', A, ', CASE ', I1, '. IND = ', I2, & ' INSTEAD OF -4'/) 803 FORMAT (/' **** DQCK DETECTED A TOTAL OF ', I2,' PROBLEMS. ****'/) 804 FORMAT (' DQCK DETECTED NO PROBLEMS.'/) end !! DQCKIN !***PURPOSE Quick check for DBSKIN. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! ABSTRACT * A DOUBLE PRECISION ROUTINE * ! DQCKIN IS A QUICK CHECK ROUTINE WHICH EXERCISES THE MAJOR ! LOOPS IN SUBROUTINE DBSKIN (X,N,KODE,M,Y,NZ,IERR) FOR BICKLEY ! FUNCTIONS KI(J,X). MORE PRECISELY, DQCKIN DOES CONSISTENCY CHECKS ! ON THE OUTPUT FROM DBSKIN BY COMPARING SINGLE EVALUATIONS (M=1) ! AGAINST SELECTED MEMBERS OF SEQUENCES WHICH ARE GENERATED BY ! RECURSION. IF THE RELATIVE ERROR IS LESS THAN 1000 TIMES UNIT ! ROUND OFF, THEN THE TEST IS PASSED - IF NOT, THEN X, THE VALUES ! TO BE COMPARED, THE RELATIVE ERROR AND PARAMETERS KODE, N, M AND K ! ARE WRITTEN ON LOGICAL UNIT 6 WHERE K IS THE MEMBER OF THE ! SEQUENCE OF LENGTH M WHICH FAILED THE TEST. THAT IS, THE INDEX ! OF THE FUNCTION WHICH FAILED THE TEST IS J=N+K-1. UNDERFLOW ! TESTS ARE MADE AND ERROR CONDITIONS ARE TRIGGERED. ! ! FUNCTIONS i1mach AND d1mach MUST BE INITIALIZED ACCORDING TO THE ! PROLOGUE IN EACH FUNCTION FOR THE MACHINE ENVIRONMENT BEFORE ! DQCKIN OR DBSKIN CAN BE EXECUTED. FIFTEEN MACHINE ENVIRONMENTS ! CAN BE DEFINED IN i1mach AND d1mach. ! !***ROUTINES CALLED d1mach, DBSKIN, i1mach !***REVISION HISTORY (YYMMDD) ! 820601 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 DQCKIN subroutine DQCKIN (LUN, KPRINT, IPASS) integer I, IERR, IFLG, IX, I1M12, J, K, KODE, LUN, M, MDEL, MM, & N, NDEL, NN integer i1mach double precision AIX, ER, TOL, V, X, XINC, Y double precision d1mach !***FIRST EXECUTABLE STATEMENT DQCKIN dimension V(1), Y(10) TOL = 1000.0D0*MAX(d1mach(4),1.0D-18) IFLG = 0 if ( KPRINT >= 3)WRITE (LUN,99999) 99999 FORMAT (1H1//35H QUICK CHECK DIAGNOSTICS FOR DBSKIN//) DO 70 KODE=1,2 N = 0 DO 60 NN=1,7 M = 1 DO 50 MM=1,4 X = 0.0D0 DO 40 IX=1,6 if ( N == 0 .and. IX == 1) GO TO 30 call DBSKIN(X, N, KODE, M, Y, NZ, IERR) DO 20 K=1,M,2 J = N + K - 1 call DBSKIN(X, J, KODE, 1, V, NZ, IERR) ER = ABS((V(1)-Y(K))/V(1)) if ( ER <= TOL) GO TO 20 if ( IFLG /= 0) GO TO 10 if ( KPRINT >= 2)WRITE (LUN,99998) 99998 FORMAT (8X, 1HX, 13X, 4HV(1), 11X, 4HY(K), 9X, 6HREL ER, & 1HR, 5X, 4HKODE, 3X, 1HN, 4X, 1HM, 4X, 1HK) 10 continue IFLG = IFLG + 1 if ( KPRINT >= 2) & write (LUN,99997) X, V(1), Y(K), ER, KODE, N, M, K 99997 FORMAT (4E15.6, 4I5) if ( IFLG > 200) GO TO 130 20 continue 30 continue AIX = 2*IX - 3 XINC = max ( 1.0D0,AIX) X = X + XINC 40 continue MDEL = max ( 1,MM-1) M = M + MDEL 50 continue NDEL = max ( 1,2*N-2) N = N + NDEL 60 continue ! ------------------------------------------------------------------ ! TEST UNDERFLOW ! ------------------------------------------------------------------ 70 continue KODE = 1 M = 10 N = 10 I1M12 = i1mach(15) X = -2.302D0*d1mach(5)*I1M12 call DBSKIN(X, N, KODE, M, Y, NZ, IERR) if ( NZ == M) GO TO 80 if ( KPRINT >= 2)WRITE (LUN,99996) 99996 FORMAT (//30H NZ IN UNDERFLOW TEST IS NOT 1//) IFLG = IFLG + 1 GO TO 110 80 continue DO 90 I=1,M if ( Y(I) /= 0.0D0) GO TO 100 90 continue GO TO 110 100 continue IFLG = IFLG + 1 if ( KPRINT >= 2)WRITE (LUN,99995) 99995 FORMAT (//43H SOME Y VALUE IN UNDERFLOW TEST IS NOT ZERO//) 110 continue if ( IFLG /= 0.OR.KPRINT < 3) GO TO 120 write (LUN,99994) 99994 FORMAT (//16H QUICK CHECKS OK//) 120 continue IPASS=0 if ( IFLG == 0)IPASS=1 return 130 continue if ( KPRINT >= 2)WRITE (LUN,99992) 99992 FORMAT (//52H PROCESSING OF MAIN LOOPS TERMINATED BECAUSE THE NUM, & 36HBER OF DIAGNOSTIC PRINTS EXCEEDS 200//) IPASS=0 if ( IFLG == 0)IPASS=1 return end !! DQCPSI !***PURPOSE Quick check for DPSIFN. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! ABSTRACT * A DOUBLE PRECISION ROUTINE * ! DQCPSI IS A QUICK CHECK ROUTINE WHICH EXERCISES THE MAJOR ! LOOPS IN SUBROUTINE DPSIFN(X,N,KODE,M,ANS,NZ,IERR) FOR DERIVATIVES ! OF THE PSI FUNCTION. FOR N=0, THE PSI FUNCTIONS ARE CALCULATED ! EXPLICITLY AND CHECKED AGAINST EVALUATIONS FROM DPSIFN. FOR ! N > 0, CONSISTENCY CHECKS ARE MADE BY COMPARING A SEQUENCE ! AGAINST SINGLE EVALUATIONS OF DPSIFN, ONE AT A TIME. ! IF THE RELATIVE ERROR IS LESS THAN 1000 TIMES THE MAXIMUM OF ! UNIT ROUNDOFF AND 1.0D-18, THEN THE TEST IS PASSED--IF NOT, ! THEN X, THE VALUES TO BE COMPARED, THE RELATIVE ERROR AND ! PARAMETERS KODE AND N ARE WRITTEN ON LOGICAL UNIT 6 WHERE N IS ! THE ORDER OF THE DERIVATIVE AND KODE IS A SELECTION PARAMETER ! DEFINED IN THE PROLOGUE TO DPSIFN. ! ! FUNCTIONS i1mach AND d1mach MUST BE INITIALIZED ACCORDING TO THE ! PROLOGUE IN EACH FUNCTION FOR THE MACHINE ENVIRONMENT BEFORE ! DQCPSI OR DPSIFN CAN BE EXECUTED. ! !***ROUTINES CALLED d1mach, DPSIFN !***REVISION HISTORY (YYMMDD) ! 820601 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 DQCPSI subroutine DQCPSI (LUN, KPRINT, IPASS) integer I, IERR, IFLG, IX, KODE, LUN, M, N, NM, NN, NZ double precision ER, EULER, PSI1, PSI2, R1M4, S, TOL, X double precision d1mach dimension PSI1(3), PSI2(20) !***FIRST EXECUTABLE STATEMENT DQCPSI DATA EULER /0.5772156649015328606D0/ R1M4 = d1mach(4) TOL = 1000.0D0*MAX(R1M4,1.0D-18) if ( KPRINT >= 3)WRITE (LUN,99999) ! ------------------------------------------------------------------ ! CHECK PSI(I) AND PSI(I-0.5), I=1,2,... ! ------------------------------------------------------------------ 99999 FORMAT (1H1//35H QUICK CHECK DIAGNOSTICS FOR DPSIFN//) IFLG = 0 N = 0 DO 50 KODE=1,2 DO 40 M=1,2 S = -EULER + (M-1)*(-2.0D0*LOG(2.0D0)) X = 1.0D0 - (M-1)*0.5D0 DO 30 I=1,20 call DPSIFN(X, N, KODE, 1, PSI2, NZ, IERR) PSI1(1) = -S + (KODE-1)*LOG(X) ER = ABS((PSI1(1)-PSI2(1))/PSI1(1)) if ( ER <= TOL) GO TO 20 if ( IFLG /= 0) GO TO 10 if ( KPRINT >= 2)WRITE (LUN,99998) 99998 FORMAT (8X, 1HX, 13X, 4HPSI1, 11X, 4HPSI2, 9X, 7HREL ERR, & 5X, 4HKODE, 3X, 1HN) 10 continue IFLG = IFLG + 1 if ( KPRINT >= 2) & write (LUN,99997) X, PSI1(1), PSI2(I), ER, KODE, N 99997 FORMAT (4E15.6, 2I5) if ( IFLG > 200) GO TO 150 20 continue S = S + 1.0D0/X X = X + 1.0D0 30 continue 40 continue ! ------------------------------------------------------------------ ! CHECK SMALL X < UNIT ROUNDOFF ! ------------------------------------------------------------------ 50 continue KODE = 1 X = TOL/10000.0D0 N = 1 call DPSIFN(X, N, KODE, 1, PSI2, NZ, IERR) PSI1(1) = X**(-N-1) ER = ABS((PSI1(1)-PSI2(1))/PSI1(1)) if ( ER <= TOL) GO TO 70 if ( IFLG /= 0) GO TO 60 if ( KPRINT >= 2)WRITE (LUN,99998) 60 continue IFLG = IFLG + 1 if ( KPRINT >= 2) & write (LUN,99997) X, PSI1(1), PSI2(1), ER, KODE, N ! ------------------------------------------------------------------ ! CONSISTENCY TESTS FOR N >= 0 ! ------------------------------------------------------------------ 70 continue DO 130 KODE=1,2 DO 120 M=1,5 DO 110 N=1,16,5 NN = N - 1 X = 0.1D0 DO 100 IX=1,25,2 X = X + 1.0D0 call DPSIFN(X, NN, KODE, M, PSI2, NZ, IERR) DO 90 I=1,M NM = NN + I - 1 call DPSIFN(X, NM, KODE, 1, PSI1, NZ, IERR) ER = ABS((PSI2(I)-PSI1(1))/PSI1(1)) if ( ER < TOL) GO TO 90 if ( IFLG /= 0) GO TO 80 if ( KPRINT >= 2)WRITE (LUN,99998) 80 continue IFLG = IFLG + 1 if ( KPRINT >= 2) & write (LUN,99997) X, PSI1(1), PSI2(I), ER, KODE, NM 90 continue 100 continue 110 continue 120 continue 130 continue if ( IFLG /= 0.OR.KPRINT < 3) GO TO 140 write (LUN,99996) 99996 FORMAT (//16H QUICK CHECKS OK//) 140 continue IPASS=0 if ( IFLG == 0)IPASS=1 return 150 continue if ( KPRINT >= 2)WRITE (LUN,99994) 99994 FORMAT (//52H PROCESSING OF MAIN LOOPS TERMINATED BECAUSE THE NUM, & 36HBER OF DIAGNOSTIC PRINTS EXCEEDS 200//) IPASS=0 if ( IFLG == 0)IPASS=1 return end !! DQFCN2 !***PURPOSE Evaluate function used in DNSQE. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SQFCN2-S, DQFCN2-D) !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine which evaluates the function for test program ! used in quick check of DNSQE. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 930214 TYPE and declarations sections added. (WRB) !***END PROLOGUE DQFCN2 ! .. Scalar Arguments .. subroutine DQFCN2 (N, X, FVEC, IFLAG) ! .. Array Arguments .. integer IFLAG, N !***FIRST EXECUTABLE STATEMENT DQFCN2 double precision FVEC(*), X(*) FVEC(1) = 1.0D0 - X(1) FVEC(2) = 10.0D0*(X(2)-X(1)**2) return end !! DQG8TS !***PURPOSE Quick check for DGAUS8. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (QG8TST-S, DQG8TS-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED d1mach, DFQD1, DFQD2, DGAUS8, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 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) ! 920213 Code restructured to test DGAUS8 for all values of KPRINT, ! second accuracy test added and testing of error returns ! revised. (WRB) !***END PROLOGUE DQG8TS ! .. Scalar Arguments .. subroutine DQG8TS (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN integer IERR, KONTRL double precision A, ANS, B, COR, ERR, REQ, TOL ! .. External Functions .. LOGICAL FATAL double precision d1mach, DFQD1, DFQD2 ! .. External Subroutines .. EXTERNAL d1mach, DFQD1, DFQD2 ! .. Intrinsic Functions .. EXTERNAL DGAUS8, XGETF, XSETF !***FIRST EXECUTABLE STATEMENT DQG8TS INTRINSIC ABS, ATAN, EXP, SQRT ! ! Initialize variables for testing. ! if ( kprint >= 2) write (LUN,FMT=9000) TOL = SQRT(d1mach(4)) ! ! First accuracy test. ! ipass = 1 A = 1.0D0 B = 4.0D0 ERR = TOL/100.0D0 call DGAUS8 (DFQD1, A, B, ERR, ANS, IERR) COR = 2.0D0 if ( ABS(ANS-COR) <= TOL .and. IERR == 1 ) then if ( kprint >= 3) & write (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR else ipass = 0 if ( kprint >= 2) & write (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR ! ! Second accuracy test. ! end if A = 0.0D0 B = 4.0D0*ATAN(1.0D0) ERR = TOL/100.0D0 call DGAUS8 (DFQD2, A, B, ERR, ANS, IERR) COR = (EXP(B)-1.0D0)/101.0D0 if ( ABS(ANS-COR) <= TOL .and. IERR == 1 ) then if ( kprint >= 3) & write (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR else ipass = 0 if ( kprint >= 2) & write (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR ! ! Test error returns. ! end if call XGETF (KONTRL) if ( kprint <= 2 ) then call XSETF (0) else call XSETF (1) end if ! FATAL = .FALSE. ! ! Test with a discontinuous integrand and a tight error tolerance. ! if ( kprint >= 3) write (LUN,FMT=9030) A = 0.0D0 B = 1.0D0 COR = 2.0D0 ERR = 100.0D0*d1mach(4) REQ = ERR ! ! See if test passed. ! call DGAUS8 (DFQD1, A, B, ERR, ANS, IERR) if ( IERR == 2 ) then if ( kprint >= 3) & write (LUN,FMT=9040) 'PASSED', REQ, ANS, IERR, ERR, COR else if ( kprint >= 2) & write (LUN,FMT=9040) 'FAILED', REQ, ANS, IERR, ERR, COR ipass = 0 FATAL = .TRUE. ! ! Test DGAUS8 with A and B nearly equal. ! end if A = 2.0D0 B = A*(1.0D0+d1mach(4)) COR = 0.0D0 ! ERR = TOL ! ! Check to see if test passed. ! call DGAUS8 (DFQD1, A, B, ERR, ANS, IERR) if ( IERR == -1 .and. ANS == 0.0D0 ) then if ( kprint >= 3) write (LUN,9050) 'PASSED' else ipass = 0 FATAL = .TRUE. if ( kprint >= 2) write (LUN,9050) 'FAILED' ! end if call XSETF (KONTRL) if ( FATAL ) then if ( kprint >= 2 ) then write (LUN, 9060) end if else if ( kprint >= 3 ) then write (LUN, 9070) end if ! end if if ( ipass == 1 .and. KPRINT >= 3) write (LUN,FMT=9080) if ( ipass == 0 .and. KPRINT >= 2) write (LUN,FMT=9090) ! return 9000 FORMAT ('1' / ' DGAUS8 Quick Check') 9010 FORMAT (/ ' Accuracy test of DGAUS8 ', A / & ' A = ', F10.5, ' B = ', F10.5 / & ' Computed result = ', D14.7, ' Exact result = ', & D14.7 / & ' Tolerance = ', D14.7, ' IERR = ', I2 /) 9030 FORMAT (/ ' Test error returns' / & ' 2 error messages expected' /) 9040 FORMAT (' Test of DGAUS8 ', A / & ' REQ =', D10.2, 5X, 'ANS =', D20.13, 5X, 'IERR =', I2, & 5X, 'should be 2' / & ' ERR =', D10.2, ' CORRECT =' ,D20.13 /) 9050 FORMAT (' Test of A and B nearly equal ', A) 9060 FORMAT (/ ' At least one incorrect argument test FAILED') 9070 FORMAT (/ ' All incorrect argument tests PASSED') 9080 FORMAT (/,' ***************DGAUS8 PASSED ALL TESTS**************') 9090 FORMAT (/,' ***************DGAUS8 FAILED SOME TESTS*************') end !! DQJAC2 !***PURPOSE !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! SUBROUTINE TO EVALUATE THE FULL JACOBIAN FOR TEST PROBLEM USED ! IN QUICK CHECK OF DNSQE. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DQJAC2 subroutine DQJAC2 (N, X, FVEC, FJAC, LDFJAC, IFLAG) integer IFLAG, LDFJAC, N !***FIRST EXECUTABLE STATEMENT DQJAC2 double precision FJAC(LDFJAC,*), FVEC(*), X(*) FJAC(1,1) = -1.0D0 FJAC(1,2) = 0.0D0 FJAC(2,1) = -2.0D1*X(1) FJAC(2,2) = 1.0D1 return end !! DQN79Q !***PURPOSE Quick check for DQNC79. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (QN79QX-S, DQN79Q-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED d1mach, DFQD1, DFQD2, DQNC79, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 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) ! 920213 Code restructured to test DQNC79 for all values of KPRINT, ! second accuracy test added and testing of error returns ! revised. (WRB) !***END PROLOGUE DQN79Q ! .. Scalar Arguments .. subroutine DQN79Q (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN integer IERR, KONTRL, NFCT double precision A, ANS, B, COR, ERR, REQ, TOL ! .. External Functions .. LOGICAL FATAL double precision d1mach, DFQD1, DFQD2 ! .. External Subroutines .. EXTERNAL d1mach, DFQD1, DFQD2 ! .. Intrinsic Functions .. EXTERNAL DQNC79, XGETF, XSETF !***FIRST EXECUTABLE STATEMENT DQN79Q INTRINSIC ABS, MAX, SQRT ! ! Initialize variables for testing. ! if ( kprint >= 2) write (LUN,FMT=9000) TOL = SQRT(d1mach(4)) ! ! First accuracy test. ! ipass = 1 A = 1.0D0 B = 4.0D0 ERR = TOL/100.0D0 call DQNC79 (DFQD1, A, B, ERR, ANS, IERR, NFCT) COR = 2.0D0 if ( ABS(ANS-COR) <= TOL .and. IERR == 1 ) then if ( kprint >= 3) & write (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR, NFCT else ipass = 0 if ( kprint >= 2) & write (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR, NFCT ! ! Second accuracy test. ! end if A = 0.0D0 B = 4.0D0*ATAN(1.0D0) ERR = TOL/10.0D0 call DQNC79 (DFQD2, A, B, ERR, ANS, IERR, NFCT) COR = (EXP(B)-1.0D0)/101.0D0 if ( ABS(ANS-COR) <= TOL .and. IERR == 1 ) then if ( kprint >= 3) & write (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR, NFCT else ipass = 0 if ( kprint >= 2) & write (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR, NFCT ! ! Test error returns. ! end if call XGETF (KONTRL) if ( kprint <= 2 ) then call XSETF (0) else call XSETF (1) end if ! FATAL = .FALSE. ! ! Test with a discontinuous integrand and a tight error tolerance. ! if ( kprint >= 3) write (LUN,FMT=9030) A = 0.0D0 B = 1.0D0 COR = 2.0D0 ERR = 100.0D0*d1mach(4) REQ = ERR ! ! See if test passed. ! call DQNC79 (DFQD1, A, B, ERR, ANS, IERR, NFCT) if ( IERR == 2 ) then if ( kprint >= 3) & write (LUN,FMT=9040) 'PASSED', REQ, ANS, IERR, ERR, COR else if ( kprint >= 2) & write (LUN,FMT=9040) 'FAILED', REQ, ANS, IERR, ERR, COR ipass = 0 FATAL = .TRUE. ! ! Test DQNC79 with A and B nearly equal. ! end if A = 2.0D0 B = A*(1.0D0+d1mach(4)) COR = 0.0D0 ! ERR = TOL ! ! Check to see if test passed. ! call DQNC79 (DFQD1, A, B, ERR, ANS, IERR, NFCT) if ( IERR == -1 .and. ANS == 0.0D0 ) then if ( kprint >= 3) write (LUN,9050) 'PASSED' else ipass = 0 FATAL = .TRUE. if ( kprint >= 2) write (LUN,9050) 'FAILED' ! end if call XSETF (KONTRL) if ( FATAL ) then if ( kprint >= 2 ) then write (LUN, 9060) end if else if ( kprint >= 3 ) then write (LUN, 9070) end if ! end if if ( ipass == 1 .and. KPRINT >= 3) write (LUN,FMT=9080) if ( ipass == 0 .and. KPRINT >= 2) write (LUN,FMT=9090) ! return 9000 FORMAT ('1' / ' DQNC79 Quick Check') 9010 FORMAT (/ ' Accuracy test of DQNC79 ', A / & ' A = ', F10.5, ' B = ', F10.5 / & ' Computed result = ', D14.7, ' Exact result = ', & D14.7 / & ' Tolerance = ', D14.7, ' IERR = ', I2, & ' Number of function evals = ', I5 /) 9030 FORMAT (/ ' Test error returns' / & ' 2 error messages expected' /) 9040 FORMAT (' Test of DQNC79 ', A / & ' REQ =', D10.2, 5X, 'ANS =', D20.13, 5X, 'IERR =', I2, & 5X, 'should be 2' / & ' ERR =', D10.2, ' CORRECT =' ,D20.13 /) 9050 FORMAT (' Test of A and B nearly equal ', A) 9060 FORMAT (/ ' At least one incorrect argument test FAILED') 9070 FORMAT (/ ' All incorrect argument tests PASSED') 9080 FORMAT (/' ***************DQNC79 PASSED ALL TESTS***************') 9090 FORMAT (/' ***************DQNC79 FAILED SOME TESTS**************') end subroutine DRMGEN (NELTMX, FACTOR, IERR, N, NELT, ISYM, IA, JA, A, & !! DRMGEN !***SUBSIDIARY !***PURPOSE This routine generates a "Random" symmetric or ! non-symmetric matrix of size N for use in the SLAP ! Quick Checks. !***LIBRARY SLATEC (SLAP) !***TYPE DOUBLE PRECISION (SRMGEN-S, DRMGEN-D) !***AUTHOR Seager, Mark K., (LLNL) ! seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO BOX 808, L-300 ! Livermore, CA 94550 ! (510) 423-3141 !***DESCRIPTION ! ! *Usage: ! INTEGER NELTMX, IERR, N, NELT, ISYM, ! INTEGER IA(NELTMX), JA(NELTMX), ITMP(N), IDIAG(N) ! DOUBLE PRECISION FACTOR, A(NELTMX), F(N), SOLN(N), DSUM(N) ! ! call DRMGEN( NELTMX, FACTOR, IERR, N, NELT, ISYM, ! $ IA, JA, A, F, SOLN, DSUM, ITMP, IDIAG ) ! ! *Arguments: ! ! NELTMX :IN Integer. ! Maximum number of non-zeros that can be created by this ! routine for storage in the IA, JA, A arrays, see below. ! FACTOR :IN Double Precision. ! Non-zeros in the upper triangle are set to FACTOR times ! the corresponding entry in the lower triangle when a non- ! symmetric matrix is requested (See ISYM, below). ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => everything went OK. ! = 1 => Ran out of space trying to create matrix. ! Set NELTMX to something larger and retry. ! N :IN Integer. ! Size of the linear system to generate (number of unknowns). ! NELT :OUT Integer. ! Number of non-zeros stored in the IA, JA, A arrays, see below. ! ISYM :IN Integer. ! Flag to indicate the type of matrix to generate: ! ISYM = 0 => Non-Symmetric Matrix (See FACTOR, above). ! = 1 => Symmetric Matrix. ! IA :OUT Integer IA(NELTMX). ! Stores the row indices for the non-zeros. ! JA :OUT Integer JA(NELTMX). ! Stores the column indices for the non-zeros. ! A :OUT Double Precision A(NELTMX). ! Stores the values of the non-zeros. ! F :OUT Double Precision F(N). ! The right hand side of the linear system. Obtained by ! multiplying the matrix times SOLN, see below. ! SOLN :OUT Double Precision SOLN(N). ! The true solution to the linear system. Each component is ! chosen at random (0.0 NELTMX ) then IERR = 1 return end if IA(NELT) = N+1-ITMP(IROW) JA(NELT) = ICOL if ( IA(NELT) == ICOL ) then IDIAG(ICOL) = NELT else A(NELT) = -RAND(DUMMY) DSUM(ICOL) = DSUM(ICOL) + A(NELT) ! ! Copy this element into upper triangle. ! if ( ISYM == 0 ) then NELT = NELT + 1 if ( NELT > NELTMX ) then IERR = 1 return end if IA(NELT) = ICOL JA(NELT) = IA(NELT-1) A(NELT) = A(NELT-1)*FACTOR DSUM(JA(NELT)) = DSUM(JA(NELT)) + A(NELT) else DSUM(IA(NELT)) = DSUM(IA(NELT)) + A(NELT) end if end if 20 continue ! ! Add a diagonal to the column. ! if ( IDIAG(ICOL) == 0 ) then NELT = NELT + 1 if ( NELT > NELTMX ) then IERR = 1 return end if IDIAG(ICOL) = NELT A(NELT) = 0.0D0 IA(NELT) = ICOL JA(NELT) = ICOL end if ! ! Clean up the diagonals. ! !VD$ NODEPCHK !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP 30 continue DO 40 I = 1, N A(IDIAG(I)) = -1.0001D0*DSUM(I) ! ! Set a random solution and determine the right-hand side. ! !VD$ NOVECTOR !VD$ NOCONCUR 40 continue DO 50 I = 1, N SOLN(I) = RAND(DUMMY) F(I) = 0.0D0 ! !VD$ NOVECTOR !VD$ NOCONCUR 50 continue DO 60 K = 1, NELT F(IA(K)) = F(IA(K)) + A(K)*SOLN(JA(K)) if ( ISYM /= 0 .and. IA(K) /= JA(K) ) then F(JA(K)) = F(JA(K)) + A(K)*SOLN(IA(K)) end if 60 continue ! -------- LAST LINE OF DRMGEN FOLLOWS ---------------------------- return end !! DSOSFN !***PURPOSE Function evaluator for DSOS quick check. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! FUNCTION WHICH EVALUATES THE FUNCTIONS, ONE AT A TIME, ! FOR TEST PROGRAM USED IN QUICK CHECK OF DSOS. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DSOSFN double precision FUNCTION DSOSFN (X, K) integer K !***FIRST EXECUTABLE STATEMENT DSOSFN double precision X(2) if ( K == 1) DSOSFN = 1.0D0 - X(1) if ( K == 2) DSOSFN = 1.0D1*(X(2) - X(1)**2) return end !! DSOSQX !***PURPOSE Quick check for DSOS. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (SOSNQX-S, DSOSQX-D) !***KEYWORDS QUICK CHECK !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! This subroutine performs a quick check on the subroutine DSOS. ! !***ROUTINES CALLED d1mach, DNRM2, DSOS, DSOSFN, PASS !***REVISION HISTORY (YYMMDD) ! 801001 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 DSOSQX ! .. Scalar Arguments .. subroutine DSOSQX (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN double precision AER, FNORM, FNORMS, RER, TOLF ! .. Local Arrays .. integer ICNT, IFLAG, IFLAGS, LIW, LWA, N double precision FVEC(2), WA(17), X(2) ! .. External Functions .. integer ITEST(2), IW(6) double precision d1mach, DNRM2, DSOSFN ! .. External Subroutines .. EXTERNAL d1mach, DNRM2, DSOSFN ! .. Intrinsic Functions .. EXTERNAL DSOS, PASS !***FIRST EXECUTABLE STATEMENT DSOSQX INTRINSIC SQRT IFLAGS = 3 FNORMS = 0.0D0 N = 2 LWA = 17 LIW = 6 TOLF = SQRT(d1mach(4)) RER = SQRT(d1mach(4)) AER = 0.0D0 ! ! Test the code with proper input values. ! if ( kprint >= 2) write (LUN,9000) IFLAG = 0 X(1) = -1.2D0 X(2) = 1.0D0 call DSOS (DSOSFN,N,X,RER,AER,TOLF,IFLAG,WA,LWA,IW,LIW) ICNT = 1 FVEC(1) = DSOSFN(X,1) FVEC(2) = DSOSFN(X,2) FNORM = DNRM2(N,FVEC,1) ITEST(ICNT) = 0 ! if ( IFLAG <= IFLAGS .and. FNORM-FNORMS <= RER) ITEST(ICNT) = 1 if ( kprint /= 0 ) then if ( KPRINT >= 3 .OR. (KPRINT>=2 .and. ITEST(ICNT) /= 1)) & write (LUN,9010) IFLAGS,FNORMS,IFLAG,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 IFLAG = 0 X(1) = -1.2D0 X(2) = 1.0D0 call DSOS (DSOSFN,N,X,RER,AER,TOLF,IFLAG,WA,LWA,IW,LIW) ICNT = 2 ITEST(ICNT) = 0 if ( IFLAG == 9) 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) if ( KPRINT >= 1 .and. ipass /= 1) write (LUN,9020) if ( KPRINT >= 2 .and. ipass == 1) write (LUN,9030) return 9000 FORMAT ('1' / ' DSOS QUICK CHECK' /) 9010 FORMAT (' EXPECTED VALUE OF IFLAG AND RESIDUAL NORM', I5, D20.5 / & ' RETURNED VALUE OF IFLAG AND RESIDUAL NORM', I5, D20.5 /) 9020 FORMAT (/' **********WARNING -- DSOS FAILED SOME TESTS**********') 9030 FORMAT (/' ----------DSOS PASSED ALL TESTS----------') end !! DSRTQC !***SUBSIDIARY !***PURPOSE Quick check for SLATEC routines DSORT, DPSORT, DPPERM !***LIBRARY SLATEC !***CATEGORY N6A !***TYPE DOUBLE PRECISION (SSRTQC-S, DSRTQC-D, ISRTQC-I, HSRTQC-H) !***KEYWORDS DPPERM, DPSORT, DSORT, QUICK CHECK !***AUTHOR Boisvert, Ronald, (NIST) !***REFERENCES (NONE) !***ROUTINES CALLED DPPERM, DPSORT, DSORT !***REVISION HISTORY (YYMMDD) ! 890620 DATE WRITTEN ! 901005 Included test of DPPERM. (MAM) ! 920511 Added error message tests. (MAM) !***END PROLOGUE DSRTQC ! subroutine DSRTQC (LUN, KPRINT, IPASS) integer N, NTEST ! PARAMETER (N=9,NTEST=4) LOGICAL FAIL double precision X(N,NTEST), XS(N,NTEST), Y(N), YC(N) integer IX(N,NTEST), IY(N), KFLAG(NTEST), KPRINT, LUN, IPASS, J, & ! ! --------- ! TEST DATA ! --------- ! ! X = TEST VECTOR ! XS = TEST VECTOR IN SORTED ORDER ! IX = PERMUTATION VECTOR, I.E. X(IX(J)) = XS(J) ! I, KABS, IER, NERR, NUMXER, NN, KKFLAG DATA KFLAG(1) / 2 / DATA (X(I,1),I=1,N) /36D0,54D0,-1D0,29D0, 1D0,80D0,98D0,99D0,55D0/ DATA (IX(I,1),I=1,N)/ 3, 5, 4, 1, 2, 9, 6, 7, 8 / ! DATA (XS(I,1),I=1,N)/-1D0, 1D0,29D0,36D0,54D0,55D0,80D0,98D0,99D0/ DATA KFLAG(2) /-1 / DATA (X(I,2),I=1,N) / 1D0, 2D0, 3D0, 4D0, 5D0, 6D0, 7D0, 8D0, 9D0/ DATA (IX(I,2),I=1,N)/ 9, 8, 7, 6, 5, 4, 3, 2, 1 / ! DATA (XS(I,2),I=1,N)/ 9D0, 8D0, 7D0, 6D0, 5D0, 4D0, 3D0, 2D0, 1D0/ DATA KFLAG(3) /-2 / DATA (X(I,3),I=1,N) /-9D0,-8D0,-7D0,-6D0,-5D0,-4D0,-3D0,-2D0,-1D0/ DATA (IX(I,3),I=1,N)/ 9, 8, 7, 6, 5, 4, 3, 2, 1 / ! DATA (XS(I,3),I=1,N)/-1D0,-2D0,-3D0,-4D0,-5D0,-6D0,-7D0,-8D0,-9D0/ DATA KFLAG(4) / 1 / DATA (X(I,4),I=1,N) /36D0,54D0,-1D0,29D0, 1D0,80D0,98D0,99D0,55D0/ DATA (IX(I,4),I=1,N)/ 3, 5, 4, 1, 2, 9, 6, 7, 8 / ! !***FIRST EXECUTABLE STATEMENT DSRTQC DATA (XS(I,4),I=1,N)/-1D0, 1D0,29D0,36D0,54D0,55D0,80D0,98D0,99D0/ if ( kprint >= 2 ) then write (LUN,2001) '=================' write (LUN,2002) 'OUTPUT FROM DSRTQC' write (LUN,2002) '=================' end if ! ! ------------------------------------------------------------- ! CHECK DSORT ! ------------------------------------------------------------- ! ipass = 1 ! ! ... SETUP PROBLEM ! DO 200 J=1,NTEST DO 110 I=1,N Y(I) = X(I,J) YC(I) = X(I,J) ! ! ... call ROUTINE TO BE TESTED ! 110 continue ! ! ... EVALUATE RESULTS ! call DSORT(Y,YC,N,KFLAG(J)) KABS = ABS(KFLAG(J)) FAIL = .FALSE. DO 120 I=1,N FAIL = FAIL .OR. (Y(I) /= XS(I,J)) & .OR. ((KABS == 1) .and. (YC(I) /= X(I,J))) & .OR. ((KABS == 2) .and. (YC(I) /= XS(I,J))) ! ! ... PRODUCE REQUIRED OUTPUT ! 120 continue if ( FAIL ) then ipass = 0 if ( kprint > 0) WRITE(LUN,2001) 'DSORT FAILED TEST ',J else if ( kprint >= 2) WRITE(LUN,2001) 'DSORT PASSED TEST ',J end if if ( (FAIL .and. (KPRINT >= 2)) .OR. (KPRINT >= 3) ) then write (LUN,2001) '------------------------' write (LUN,2002) 'DETAILS OF DSORT TEST ',J write (LUN,2002) '------------------------' write (LUN,2002) '1ST ARGUMENT (VECTOR TO BE SORTED)' write (LUN,2003) ' INPUT = ',(X(I,J),I=1,N) write (LUN,2003) ' COMPUTED OUTPUT = ',(Y(I),I=1,N) write (LUN,2003) ' CORRECT OUTPUT = ',(XS(I,J),I=1,N) write (LUN,2002) '2ND ARGUMENT (VECTOR CARRIED ALONG)' write (LUN,2003) ' INPUT = ',(X(I,J),I=1,N) write (LUN,2003) ' COMPUTED OUTPUT = ',(YC(I),I=1,N) if ( KABS == 1 ) then write (LUN,2003) ' CORRECT OUTPUT = ',(X(I,J),I=1,N) else write (LUN,2003) ' CORRECT OUTPUT = ',(XS(I,J),I=1,N) end if write (LUN,2002) '3RD ARGUMENT (VECTOR LENGTH)' write (LUN,2004) ' INPUT = ',N write (LUN,2002) '4TH ARGUMENT (TYPE OF SORT)' write (LUN,2004) ' INPUT = ',KFLAG(J) end if ! ! ------------------------------------------------------------- ! CHECK DPSORT ! ------------------------------------------------------------- ! 200 continue ! ! ... SETUP PROBLEM ! DO 300 J=1,NTEST DO 210 I=1,N Y(I) = X(I,J) ! ! ... call ROUTINE TO BE TESTED ! 210 continue ! ! ... EVALUATE RESULTS ! call DPSORT(Y,N,IY,KFLAG(J),IER) KABS = ABS(KFLAG(J)) FAIL = .FALSE. .OR. (IER > 0) DO 220 I=1,N FAIL = FAIL .OR. (IY(I) /= IX(I,J)) & .OR. ((KABS == 1) .and. (Y(I) /= X(I,J))) & .OR. ((KABS == 2) .and. (Y(I) /= XS(I,J))) ! ! ... PRODUCE REQUIRED OUTPUT ! 220 continue if ( FAIL ) then ipass = 0 if ( kprint > 0) WRITE(LUN,2001) 'DPSORT FAILED TEST ',J else if ( kprint >= 2) WRITE(LUN,2001) 'DPSORT PASSED TEST ',J end if if ( (FAIL .and. (KPRINT >= 2)) .OR. (KPRINT >= 3) ) then write (LUN,2001) '-------------------------' write (LUN,2002) 'DETAILS OF DPSORT TEST ',J write (LUN,2002) '-------------------------' write (LUN,2002) '1ST ARGUMENT (VECTOR TO BE SORTED)' write (LUN,2003) ' INPUT = ',(X(I,J),I=1,N) write (LUN,2003) ' COMPUTED OUTPUT = ',(Y(I),I=1,N) if ( KABS == 1 ) then write (LUN,2003) ' CORRECT OUTPUT = ',(X(I,J),I=1,N) else write (LUN,2003) ' CORRECT OUTPUT = ',(XS(I,J),I=1,N) end if write (LUN,2002) '2ND ARGUMENT (VECTOR LENGTH)' write (LUN,2004) ' INPUT = ',N write (LUN,2002) '3RD ARGUMENT (PERMUTATION VECTOR)' write (LUN,2004) ' COMPUTED OUTPUT = ',(IY(I),I=1,N) write (LUN,2004) ' CORRECT OUTPUT = ',(IX(I,J),I=1,N) write (LUN,2002) '4TH ARGUMENT (TYPE OF SORT)' write (LUN,2004) ' INPUT = ',KFLAG(J) ! end if ! ! ... TEST ERROR MESSAGES ! 300 continue if ( kprint <= 2 ) then call xsetf ( 0 ) else call xsetf ( -1 ) ! end if NN=-1 KKFLAG=1 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DPSORT(Y,NN,IY,KKFLAG,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 NN=1 KKFLAG=0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DPSORT(Y,NN,IY,KKFLAG,IER) if ( NUMXER(NERR) /= IER)IPASS=0 if ( (KPRINT >= 2) .and. (IPASS == 1) ) then write (LUN,*) write (LUN,*)' DPSORT PASSED ERROR MESSAGE TESTS' else if ( (KPRINT >= 1) .and. (IPASS == 0) ) then write (LUN,*) write (LUN,*)' DPSORT FAILED ERROR MESSAGE TESTS' ! ! CHECK DPPERM ! end if ! ! ... SETUP PROBLEM ! DO 400 J=1,NTEST KABS = ABS(KFLAG(J)) DO 310 I=1,N Y(I) = X(I,J) if ( KABS == 1 ) then IY(I) = I else IY(I) = IX(I,J) end if ! ! ... call ROUTINE TO BE TESTED ! 310 continue ! ! ... EVALUATE RESULTS ! call DPPERM(Y,N,IY,IER) FAIL = .FALSE. .OR. (IER > 0) DO 320 I=1,N FAIL = FAIL .OR. ((KABS == 1) .and. (IY(I) /= I)) & .OR. ((KABS == 2) .and. (IY(I) /= IX(I,J))) & .OR. ((KABS == 1) .and. (Y(I) /= X(I,J))) & .OR. ((KABS == 2) .and. (Y(I) /= XS(I,J))) ! ! ... PRODUCE REQUIRED OUTPUT ! 320 continue if ( FAIL ) then ipass = 0 if ( kprint > 0) WRITE(LUN,2001)'DPPERM FAILED TEST ',J else if ( KPRINT >= 2) WRITE(LUN,2001)'DPPERM PASSED TEST ',J end if if ( (FAIL .and. (KPRINT >= 2)) .OR. (KPRINT>=3) ) then write (LUN,2001)'------------------------' write (LUN,2002)'DETAILS OF DPPERM TEST',J write (LUN,2002)'------------------------' write (LUN,2002)'1ST ARGUMENT (VECTOR TO BE PERMUTED)' write (LUN,2003)' INPUT =',(X(I,J),I=1,N) write (LUN,2003)' COMPUTED OUTPUT =',(Y(I),I=1,N) if ( KABS == 1 ) then write (LUN,2003)' CORRECT OUTPUT =',(X(I,J),I=1,N) else write (LUN,2003)' CORRECT OUTPUT =',(XS(I,J),I=1,N) end if write (LUN,2002)'2ND ARGUMENT (VECTOR LENGTH)' write (LUN,2004)' INPUT =',N write (LUN,2002)'3RD ARGUMENT (PERMUTATION VECTOR)' write (LUN,2004)' INPUT =',(IY(I),I=1,N) write (LUN,2002)'4TH ARGUMENT (ERROR FLAG)' write (LUN,2004)' OUTPUT =',IER ! end if ! ! ... TEST ERROR MESSAGES ! 400 continue if ( kprint <= 2 ) then call xsetf ( 0 ) else call xsetf ( -1 ) ! end if NN=-1 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DPPERM(Y,NN,IY,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 NN=1 IY(1)=5 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call DPPERM(Y,NN,IY,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 if ( (KPRINT >= 2) .and. (IPASS == 1) ) then write (LUN,*) write (LUN,*)' DPPERM PASSED ERROR MESSAGE TESTS' else if ( (KPRINT >= 1) .and. (IPASS == 0) ) then write (LUN,*) write (LUN,*)' DPPERM FAILED ERROR MESSAGE TESTS' ! end if ! return 2001 FORMAT(/ 1X,A,I2) 2002 FORMAT(1X,A,I2) 2003 FORMAT(1X,A,9F4.0) 2004 FORMAT(1X,A,9I4) end !! DT0 !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED DF0S !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DT0 double precision FUNCTION DT0 (X) !***FIRST EXECUTABLE STATEMENT DT0 double precision A,B,DF0S,X,X1,Y A = 0.0D+00 B = 0.1D+01 X1 = X+0.1D+01 Y = (B-A)/X1+A DT0 = (B-A)*DF0S(Y)/X1/X1 return end !! DT1 !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED DF1S !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DT1 double precision FUNCTION DT1 (X) !***FIRST EXECUTABLE STATEMENT DT1 double precision A,B,DF1S,X,X1,Y A = 0.0D+00 B = 0.1D+01 X1 = X+0.1D+01 Y = (B-A)/X1+A DT1 = (B-A)*DF1S(Y)/X1/X1 return end !! DT2 !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED DF2S !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DT2 double precision FUNCTION DT2 (X) !***FIRST EXECUTABLE STATEMENT DT2 double precision A,B,DF2S,X,X1,Y A = 0.1D+00 B = 0.1D+01 X1 = X+0.1D+01 Y = (B-A)/X1+A DT2 = (B-A)*DF2S(Y)/X1/X1 return end !! DT3 !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED DF3S !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DT3 double precision FUNCTION DT3 (X) !***FIRST EXECUTABLE STATEMENT DT3 double precision A,B,DF3S,X,X1,Y A = 0.0D+00 B = 0.5D+01 X1 = X+0.1D+01 Y = (B-A)/X1+A DT3 = (B-A)*DF3S(Y)/X1/X1 return end !! DT4 !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED DF4S !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DT4 double precision FUNCTION DT4 (X) !***FIRST EXECUTABLE STATEMENT DT4 double precision A,B,DF4S,X,X1,Y A = 0.0D+00 B = 0.1D+01 X1 = X+0.1D+01 Y = (B-A)/X1+A DT4 = (B-A)*DF4S(Y)/X1/X1 return end !! DT5 !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED DF5S !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE DT5 double precision FUNCTION DT5 (X) !***FIRST EXECUTABLE STATEMENT DT5 double precision A,B,DF5S,X,X1,Y A = 0.0D+00 B = 0.1D+01 X1 = X+0.1D+01 Y = (B-A)/X1+A DT5 = (B-A)*DF5S(Y)/X1/X1 return end !! DTEST !***PURPOSE Compare arrays DCOMP and DTRUE. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (STEST-S, DTEST-D) !***KEYWORDS QUICK CHECK !***AUTHOR Lawson, C. L., (JPL) !***DESCRIPTION ! ! This subroutine compares arrays DCOMP and DTRUE of length LEN to ! see if the term by term differences, multiplied by DFAC, are ! negligible. In the case of a significant difference, appropriate ! messages are written. ! !***ROUTINES CALLED d1mach !***COMMON BLOCKS COMBLA !***REVISION HISTORY (YYMMDD) ! 741210 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900820 Modified IF test to use function DDIFF and made cosmetic ! changes to routine. (WRB) ! 901005 Removed usage of DDIFF in favour of d1mach. (RWC) ! 910501 Added TYPE record. (WRB) ! 920211 Code restructured and information added to the DESCRIPTION ! section. (WRB) !***END PROLOGUE DTEST subroutine DTEST (LEN, DCOMP, DTRUE, DSIZE, DFAC, KPRINT) double precision DCOMP(*), DTRUE(*), DSIZE(*), DFAC, DD, & RELEPS, d1mach LOGICAL PASS COMMON /COMBLA/ NPRINT, ICASE, N, INCX, INCY, MODE, PASS SAVE RELEPS !***FIRST EXECUTABLE STATEMENT DTEST DATA RELEPS /0.0D0/ if ( RELEPS == 0.0D0) RELEPS = d1mach(4) DO 100 I = 1,LEN DD = ABS(DCOMP(I)-DTRUE(I)) ! ! Here DCOMP(I) is not close to DTRUE(I). ! if ( DFAC*DD > ABS(DSIZE(I))*RELEPS ) then ! ! Print FAIL message and header. ! if ( PASS ) then PASS = .FALSE. if ( kprint >= 3 ) then write (NPRINT,9000) write (NPRINT,9010) end if end if if ( kprint >= 3) write (NPRINT,9020) ICASE, N, INCX, INCY, & MODE, I, DCOMP(I), DTRUE(I), DD, DSIZE(I) end if 100 continue return 9000 FORMAT ('+', 39X, 'FAIL') 9010 FORMAT ('0CASE N INCX INCY MODE I', 29X, 'COMP(I)', 29X, & 'TRUE(I)', 2X, 'DIFFERENCE', 5X, 'SIZE(I)' / 1X) 9020 FORMAT (1X, I4, I3, 3I5, I3, 2D36.18, 2D12.4) end !! DUIVP !***PURPOSE Dummy routine for DBVSUP quick check. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (UIVP-S, DUIVP-D) !***KEYWORDS QUICK CHECK !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! This routine is never called; it is here to prevent loaders from ! complaining about undefined externals while testing DBVSUP. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920401 Variables declaration and TYPE sections added. (WRB) !***END PROLOGUE DUIVP ! .. Scalar Arguments .. subroutine DUIVP (X, Y, YP) ! .. Array Arguments .. double precision X !***FIRST EXECUTABLE STATEMENT DUIVP double precision Y(*), YP(*) STOP end !! DUTERR !***SUBSIDIARY !***PURPOSE Output error messages for the SLAP Quick Check. !***LIBRARY SLATEC (SLAP) !***TYPE DOUBLE PRECISION (OUTERR-S, DUTERR-D) !***AUTHOR Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-300 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 890404 DATE WRITTEN ! 890920 Converted prologue to SLATEC 4.0 format. (FNF) ! 920511 Added complete declaration section. (WRB) ! 921021 Changed E's to 1P,D's in output formats. (FNF) !***END PROLOGUE DUTERR ! .. Scalar Arguments .. subroutine DUTERR (METHOD, IERR, IOUT, nfail, ISTDO, ITER, ERR) double precision ERR integer IERR, IOUT, ISTDO, ITER, nfail !***FIRST EXECUTABLE STATEMENT DUTERR CHARACTER METHOD*6 if ( IERR /= 0 ) nfail = nfail + 1 if ( IOUT == 1 .and. IERR /= 0 ) then write (ISTDO,1000) METHOD end if if ( IOUT == 2 ) then if ( IERR == 0 ) then write (ISTDO,1010) METHOD else write (ISTDO,1020) METHOD,IERR,ITER,ERR end if end if if ( IOUT >= 3 ) then if ( IERR == 0 ) then write (ISTDO,1030) METHOD,IERR,ITER,ERR else write (ISTDO,1020) METHOD,IERR,ITER,ERR end if end if return 1000 FORMAT( 1X,A6,' : **** FAILURE ****') 1010 FORMAT( 1X,A6,' : **** PASSED ****') 1020 FORMAT(' **************** WARNING ***********************'/ & ' **** ',A6,' Quick Test FAILED: IERR = ',I5,' ****'/ & ' **************** WARNING ***********************'/ & ' Iteration Count = ',I3,' Stop Test = ',1P,D12.6) 1030 FORMAT(' ***************** PASSED ***********************'/ & ' **** ',A6,' Quick Test PASSED: IERR = ',I5,' ****'/ & ' ***************** PASSED ***********************'/ & ! -------- LAST LINE OF DUTERR FOLLOWS ---------------------------- ' Iteration Count = ',I3,' Stop Test = ',1P,D12.6) end !! DUVEC !***PURPOSE Dummy routine for DBVSUP quick check. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (UVEC-S, DUVEC-D) !***KEYWORDS QUICK CHECK !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! This routine is never called; it is here to prevent loaders from ! complaining about undefined externals while testing DBVSUP. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920401 Variables declaration and TYPE sections added. (WRB) !***END PROLOGUE DUVEC ! .. Scalar Arguments .. subroutine DUVEC (X, Y, YP) ! .. Array Arguments .. double precision X !***FIRST EXECUTABLE STATEMENT DUVEC double precision Y(*), YP(*) STOP end subroutine DXCSRT (DNU1, NUDIFF, MU1, MU2, THETA, P, Q, R, IP, IQ, & !! DXCSRT !***PURPOSE TO COMPUTE CHECK VALUES FOR LEGENDRE FUNCTIONS !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE SINGLE PRECISION (XCRST-S, DXCRST-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR SMITH, JOHN M., (NBS AND GEORGE MASON UNIVERSITY) !***DESCRIPTION ! ! SUBROUTINE DXCSRT CALCULATES CASORATI (CROSS PRODUCT) ! CHECK VALUES AND STORES THEM IN ARRAYS C1 AND C2 WITH ! EXPONENTS IN ARRAYS IC1 AND IC2. CALCULATIONS ARE BASED ! ON PREVIOUSLY CALCULATED LEGENDRE FUNCTIONS OF THE ! FIRST KIND (NEGATIVE ORDER) IN ARRAY P, THE SECOND KIND ! IN ARRAY Q, THE FIRST KIND (POSITIVE ORDER) IN ARRAY R. ! RESULTS SHOULD BE 1.0 TO WITHIN ROUNDOFF ERROR. ! !***SEE ALSO FCNQX2 !***REFERENCES OLVER AND SMITH,J.COMPUT.PHYSICS,51(1983),NO.3,502-518. !***ROUTINES CALLED DXADD, DXADJ, DXRED !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) !***END PROLOGUE DXCSRT IR, C1, IC1, C2, IC2, IERROR) double precision C1,C2,DMU,DMU1,NU,DNU1,P,Q,R,THETA,SX,X1,X2 dimension P(*),IP(*),Q(*),IQ(*),R(*),IR(*) ! ! PLACE ALL INPUT IN ADJUSTED FORM. ! !***FIRST EXECUTABLE STATEMENT DXCSRT dimension C1(*),IC1(*),C2(*),IC2(*) IERROR=0 L=NUDIFF+(MU2-MU1)+1 LM1=L-1 DO 500 I=1,L call DXADJ(P(I),IP(I),IERROR) if ( IERROR /= 0) RETURN call DXADJ(Q(I),IQ(I),IERROR) if ( IERROR /= 0) RETURN call DXADJ(R(I),IR(I),IERROR) if ( IERROR /= 0) RETURN ! ! CHECKS FOR FIXED MU, VARIABLE NU ! 500 continue if ( MU2 > MU1) GO TO 700 DMU1=MU1 DO 650 I=1,LM1 C1(I)=0.D0 C2(I)=0.D0 ! ! CASORATI 2 ! ! (MU+NU+1)*P(-MU,NU+1,X)*Q(MU,NU,X) ! +(MU-NU-1)*P(-MU,NU,X)*Q(MU,NU+1,X)=COS(MU*PI) ! NU=DNU1+I-1.D0 X1=P(I+1)*Q(I) IX1=IP(I+1)+IQ(I) call DXADJ(X1,IX1,IERROR) if ( IERROR /= 0) RETURN X2=P(I)*Q(I+1) IX2=IP(I)+IQ(I+1) call DXADJ(X2,IX2,IERROR) if ( IERROR /= 0) RETURN X1=(DMU1+NU+1.D0)*X1 X2=(DMU1-NU-1.D0)*X2 call DXADD(X1,IX1,X2,IX2,C1(I),IC1(I),IERROR) if ( IERROR /= 0) RETURN call DXADJ(C1(I),IC1(I),IERROR) ! ! MULTIPLY BY (-1)**MU SO THAT CHECK VALUE IS 1. ! if ( IERROR /= 0) RETURN ! ! CASORATI 1 ! ! P(MU,NU+1,X)*Q(MU,NU,X)-P(MU,NU,X)*Q(MU,NU+1,X)= ! GAMMA(NU+MU+1)/GAMMA(NU-MU+2) ! C1(I)=C1(I)*(-1)**MU1 if ( DMU1 >= NU+1.D0 .and. MOD(NU,1.D0) == 0.D0) GO TO 630 X1=R(I+1)*Q(I) IX1=IR(I+1)+IQ(I) call DXADJ(X1,IX1,IERROR) if ( IERROR /= 0) RETURN X2=R(I)*Q(I+1) IX2=IR(I)+IQ(I+1) call DXADJ(X2,IX2,IERROR) if ( IERROR /= 0) RETURN call DXADD(X1,IX1,-X2,IX2,C2(I),IC2(I),IERROR) ! ! DIVIDE BY (NU+MU),(NU+MU-1),(NU+MU-2),....(NU-MU+2), ! SO THAT CHECK VALUE IS 1. ! if ( IERROR /= 0) RETURN K=2*MU1-1 DO 620 J=1,K if ( K <= 0) GO TO 620 C2(I)=C2(I)/(NU+DMU1+1.D0-J) 620 call DXADJ(C2(I),IC2(I),IERROR) if ( IERROR /= 0) RETURN if ( K <= 0) C2(I)=(NU+1.D0)*C2(I) GO TO 650 630 C2(I)=0.D0 IC2(I)=0 650 continue ! ! CHECKS FOR FIXED NU, VARIABLE MU ! GO TO 800 700 continue SX=SIN(THETA) DO 750 I=1,LM1 C1(I)=0.D0 ! ! CASORATI 4 ! ! (MU+NU+1)*(MU-NU)*P(-(MU+1),NU,X)*Q(MU,NU,X) ! -P(-MU,NU,X)*Q(MU+1,NU,X)=COS(MU*PI)/SQRT(1-X**2) ! C2(I)=0.D0 MU=MU1+I-1 DMU=MU X1=P(I+1)*Q(I) IX1=IP(I+1)+IQ(I) call DXADJ(X1,IX1,IERROR) if ( IERROR /= 0) RETURN X2=P(I)*Q(I+1) IX2=IP(I)+IQ(I+1) call DXADJ(X2,IX2,IERROR) if ( IERROR /= 0) RETURN ! ! MULTIPLY BY SQRT(1-X**2)*(-1)**MU SO THAT CHECK VALUE IS 1. ! X1=(DMU+DNU1+1.D0)*(DMU-DNU1)*X1 call DXADD(X1,IX1,-X2,IX2,C1(I),IC1(I),IERROR) if ( IERROR /= 0) RETURN C1(I)=SX*C1(I)*(-1)**MU call DXADJ(C1(I),IC1(I),IERROR) ! ! CASORATI 3 ! ! P(MU+1,NU,X)*Q(MU,NU,X)-P(MU,NU,X)*Q(MU+1,NU,X)= ! GAMMA(NU+MU+1)/(GAMMA(NU-MU+1)*SQRT(1-X**2)) ! if ( IERROR /= 0) RETURN if ( DMU >= DNU1+1.D0 .and. MOD(DNU1,1.D0) == 0.D0) GO TO 750 X1=R(I+1)*Q(I) IX1=IR(I+1)+IQ(I) call DXADJ(X1,IX1,IERROR) if ( IERROR /= 0) RETURN X2=R(I)*Q(I+1) IX2=IR(I)+IQ(I+1) call DXADJ(X2,IX2,IERROR) if ( IERROR /= 0) RETURN call DXADD(X1,IX1,-X2,IX2,C2(I),IC2(I),IERROR) ! ! MULTIPLY BY SQRT(1-X**2) AND THEN DIVIDE BY ! (NU+MU),(NU+MU-1),(NU+MU-2),...,(NU-MU+1) SO THAT ! CHECK VALUE IS 1. ! if ( IERROR /= 0) RETURN C2(I)=C2(I)*SX K=2*MU if ( K <= 0) GO TO 750 DO 740 J=1,K C2(I)=C2(I)/(DNU1+DMU+1.D0-J) 740 call DXADJ(C2(I),IC2(I),IERROR) if ( IERROR /= 0) RETURN ! ! PLACE RESULTS IN REDUCED FORM. ! 750 continue 800 DO 810 I=1,LM1 call DXRED(C1(I),IC1(I),IERROR) if ( IERROR /= 0) RETURN call DXRED(C2(I),IC2(I),IERROR) if ( IERROR /= 0) RETURN 810 continue return end !! EDIT2 !***SUBSIDIARY !***PURPOSE Subsidiary to SDASQC. !***LIBRARY SLATEC (DASSL) !***TYPE SINGLE PRECISION (EDIT2-S, DEDIT2-D) !***AUTHOR PETZOLD, LINDA R., (LLNL) !***SEE ALSO SDASQC !***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 EDIT2 subroutine EDIT2 (Y, T, ERM) REAL Y(*), T, ERM integer I, J, K, NG REAL ALPH1, ALPH2, A1, A2, ER, EX, YT !***FIRST EXECUTABLE STATEMENT EDIT2 DATA ALPH1/1.0E0/, ALPH2/1.0E0/, NG/5/ ERM = 0.0E0 if ( T == 0.0E0) RETURN EX = 0.0E0 if ( T <= 30.0E0) EX = EXP(-2.0E0*T) A2 = 1.0E0 DO 60 J = 1,NG A1 = 1.0E0 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 !! EG8CK !***PURPOSE Quick check for EXINT and GAUS8. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (EG8CK-S, DEG8CK-D) !***KEYWORDS QUICK CHECK !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! EG8CK is a quick check routine for EXINT and GAUS8. Exponential ! integrals from EXINT are checked against quadratures from GAUS8. ! !***ROUTINES CALLED EXINT, FEIN, GAUS8, R1MACH !***COMMON BLOCKS FEINX !***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 EXINT. (WRB) !***END PROLOGUE EG8CK subroutine EG8CK (LUN, KPRINT, IPASS) COMMON /FEINX/ X, A, FKM integer I, ICASE, IE, IERR, II, IK, IPASS, IX, IY, K, KE, KK, & KODE, KX, LUN, M, N, NM, NZ REAL A, ANS, ATOL, BB, EN, ER, EX, FKM, SIG, SUM, TOL, T1, T2, X, & XX, Y REAL R1MACH, FEIN dimension EN(4), Y(4), XX(5) LOGICAL FATAL !***FIRST EXECUTABLE STATEMENT EG8CK EXTERNAL FEIN if ( kprint >= 2) write (LUN,90000) IPASS=1 TOL = SQRT(MAX(R1MACH(4),1.0E-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.20E0 call EXINT(X, N, KODE, M, TOL, EN, NZ, IERR) KX = X+0.5E0 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.0E0/X T2 = 1.0E0 SUM = 0.0E0 20 continue T1 = T2 T2 = T2 + SIG ATOL = TOL call GAUS8(FEIN, T1, T2, ATOL, ANS, IERR) SUM = SUM + ANS if ( ABS(ANS) < ABS(SUM)*TOL) GO TO 30 GO TO 20 30 continue EX = 1.0E0 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.0E0 KK = KK + 1 70 continue if ( ICASE /= 3) GO TO 100 ! ! Backward recur ! 80 BB = A - 1.0E0 DO 90 I=1,IE Y(II-1) = (EX-BB*Y(II))/X BB = BB - 1.0E0 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.0E0 XX(2) = 1.0E0 XX(3) = 1.0E0 XX(4) = 1.0E0 XX(5) = 0.01E0 DO 170 I=1,5 XX(I) = -XX(I) K = XX(2) N = XX(3) M = XX(4) call EXINT (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.0E0 TOL = 1.0E-2 call EXINT (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 EXINT AND GAUS8' /) 90010 FORMAT (// ' ERROR IN EG8CK 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 (/ ' **********EXINT AND GAUS8 PASSED ALL TESTS**********') 90110 FORMAT (/ ' **********EXINT OR GAUS8 FAILED SOME TESTS**********') end !! EISQX1 !***PURPOSE Quick check for SGEEV and CGEEV. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! THIS QUICK CHECK ROUTINE IS WRITTEN FOR EISPACK DRIVERS ! SGEEV AND CGEEV. THE EIGENVALUES OF INPUT MATRIX A(.,.) ! ARE STORED IN EK(.). RELERR IS THE RELATIVE ACCURACY ! REQUIRED FOR THEM TO PASS. ! !***ROUTINES CALLED CGEEV, R1MACH, SGEEV !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900405 call to XERROR replaced by message to LUN. (WRB) !***END PROLOGUE EISQX1 subroutine EISQX1 (LUN, KPRINT, IPASS) integer KPRINT,IPASS,LUN integer LDA,N,LDV,JOB,I,J,ID REAL A(3,3),EK(3),W(9) REAL ERR,ERRI,RELERR,RECJ COMPLEX AC(3,3),EC(3),VC(3,3) DATA LDA,N,LDV / 3*3 / DATA A / 1., -2., 6., -1., 0., -3., 2., 5., 6. / !***FIRST EXECUTABLE STATEMENT EISQX1 DATA EK / -1., 3., 5. / ipass = 1 RELERR = SQRT(R1MACH(4)) DO 20 J=1,N DO 10 I=1,N AC(I,J) = CMPLX(A(I,J),0.) 10 continue 20 continue JOB = 1 call CGEEV(AC,LDA,N,EC,VC,LDV,W,JOB,INFO) if ( INFO /= 0 ) then if ( kprint >= 2) write (LUN, 688) 'CGEEV', INFO ipass = 0 end if DO 40 J=1,N ERR = ABS(AIMAG(EC(J))) if ( ERR >= RELERR) ipass = 0 RECJ = REAL(EC(J)) ERR = ABS(RECJ - EK(1)) ID = 1 DO 30 I=2,N ERRI = ABS(RECJ - EK(I)) if ( ERRI < ERR) ID = I ERR = min ( ERRI,ERR) 30 continue if ( ABS(RECJ-EK(ID))/ABS(EK(ID)) >= RELERR) ipass = 0 40 continue JOB = 0 call SGEEV(A,LDA,N,EC,VC,LDV,W,JOB,INFO) if ( INFO /= 0 ) then if ( kprint >= 2) write (LUN, 688) 'SGEEV', INFO ipass = 0 end if DO 60 J=1,N ERR = ABS(AIMAG(EC(J))) if ( ERR >= RELERR) ipass = 0 RECJ = REAL(EC(J)) ERR = ABS(RECJ - EK(1)) ID = 1 DO 50 I=2,N ERRI = ABS(RECJ - EK(I)) if ( ERRI < ERR) ID = I ERR = min ( ERRI,ERR) 50 continue if ( ABS(RECJ-EK(ID))/ABS(EK(ID)) >= RELERR) ipass = 0 60 continue if ( KPRINT >= 2 .and. ipass /= 0) write (LUN,670) 670 FORMAT(25H EISQX1 PASSES ALL TESTS.) if ( KPRINT >= 1 .and. ipass == 0) write (LUN,680) 680 FORMAT(25H EISQX1 FAILS SOME TESTS.) 688 FORMAT (1X, 'Eigenvalue iteration failed to converge in ', A5, & ', INFO = ', I4) return end !! EISQX2 !***PURPOSE Quick check for SSIEV, CHIEV and SSPEV. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Kahaner, D. K., (NBS) !***DESCRIPTION ! ! THIS QUICK CHECK ROUTINE IS WRITTEN FOR EISPACK DRIVERS ! SSIEV, CHIEV AND SSPEV. THE EIGENVALUES OF INPUT MATRIX ! A(.,.) ARE STORED IN EK(.). RELERR IS THE RELATIVE ! ACCURACY REQUIRED FOR THEM TO PASS. ! !***ROUTINES CALLED CHIEV, R1MACH, SSIEV, SSPEV !***REVISION HISTORY (YYMMDD) ! 800808 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900405 call to XERROR replaced by message to LUN. (WRB) !***END PROLOGUE EISQX2 subroutine EISQX2 (LUN, KPRINT, IPASS) integer KPRINT,IPASS,LUN integer LDA,N,LDV,JOB,I,J,ID REAL A1(4,4),A2(10),AP(10),E(4),V(4,4),EK(4),W(16) REAL ERR,ERRI,RELERR COMPLEX AC(4,4),VC(4,4) EQUIVALENCE (V,VC) DATA LDA,N,LDV / 3*4 / DATA AP / 5., 4., 5., 1., 1., 4., 1., 1., 2., 4. / !***FIRST EXECUTABLE STATEMENT EISQX2 DATA EK / 1., 2., 5., 10. / ipass = 1 RELERR = SQRT(R1MACH(4)) ID = 0 DO 20 J=1,N DO 10 I=1,J ID = ID + 1 A1(I,J) = AP(ID) A2(ID) = AP(ID) AC(I,J) = CMPLX(AP(ID),0.) 10 continue 20 continue JOB = 1 call CHIEV(AC,LDA,N,E,VC,LDV,W,JOB,INFO) if ( INFO /= 0 ) then if ( kprint >= 2) write (LUN, 688) 'CHIEV', INFO ipass = 0 end if DO 40 J=1,N ERR = ABS(E(J) - EK(1)) ID = 1 DO 30 I=2,N ERRI = ABS(E(J) - EK(I)) if ( ERRI < ERR) ID = I ERR = min ( ERRI,ERR) 30 continue if ( ABS(E(J)-EK(ID))/ABS(EK(ID)) >= RELERR) ipass = 0 40 continue call SSIEV(A1,LDA,N,E,W,JOB,INFO) if ( INFO /= 0 ) then if ( kprint >= 2) write (LUN, 688) 'SSIEV', INFO ipass = 0 end if DO 60 J=1,N ERR = ABS(E(J) - EK(1)) ID = 1 DO 50 I=2,N ERRI = ABS(E(J) - EK(I)) if ( ERRI < ERR) ID = I ERR = min ( ERRI,ERR) 50 continue if ( ABS(E(J)-EK(ID))/ABS(EK(ID)) >= RELERR) ipass = 0 60 continue JOB = 0 call SSPEV(A2,N,E,V,LDV,W,JOB,INFO) if ( INFO /= 0 ) then if ( kprint >= 2) write (LUN, 688) 'SSPEV', INFO ipass = 0 end if DO 80 J=1,N ERR = ABS(E(J) - EK(1)) ID = 1 DO 70 I=2,N ERRI = ABS(E(J) - EK(I)) if ( ERRI < ERR) ID = I ERR = min ( ERRI,ERR) 70 continue if ( ABS(E(J)-EK(ID))/ABS(EK(ID)) >= RELERR) ipass = 0 80 continue if ( KPRINT >= 2 .and. ipass /= 0) write (LUN,684) 684 FORMAT(25H EISQX2 PASSES ALL TESTS.) if ( KPRINT >= 1 .and. ipass == 0) write (LUN,686) 686 FORMAT(25H EISQX2 FAILS SOME TESTS.) 688 FORMAT (1X, 'Eigenvalue iteration failed to converge in ', A5, & ', INFO = ', I4) return end !! EVCHCK !***SUBSIDIARY !***PURPOSE Test evaluation accuracy of CHFDV and CHFEV for PCHQK1. !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE PRECISION (EVCHCK-S, DEVCHK-D) !***KEYWORDS PCHIP EVALUATOR QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! -------- CODE TO TEST EVALUATION ACCURACY OF CHFDV AND CHFEV -------- ! ! USING FUNCTION AND DERIVATIVE VALUES FROM A CUBIC (COMPUTED IN ! DOUBLE PRECISION) AT NINT DIFFERENT (X1,X2) PAIRS: ! 1. CHECKS THAT CHFDV AND CHFEV BOTH REPRODUCE ENDPOINT VALUES. ! 2. EVALUATES AT NPTS POINTS, 10 OF WHICH ARE OUTSIDE THE INTERVAL ! AND: ! A. CHECKS ACCURACY OF CHFDV FUNCTION AND DERIVATIVE VALUES ! AGAINST EXACT VALUES. ! B. CHECKS THAT RETURNED VALUES OF NEXT SUM TO 10. ! C. CHECKS THAT FUNCTION VALUES FROM CHFEV AGREE WITH THOSE ! FROM CHFDV. ! ! ! FORTRAN INTRINSICS USED: ABS, MAX, MIN. ! FORTRAN LIBRARY ROUTINES USED: SQRT, (READ), (WRITE). ! SLATEC LIBRARY ROUTINES USED: CHFDV, CHFEV, R1MACH, RAND. ! OTHER ROUTINES USED: FDTRUE. ! !***ROUTINES CALLED CHFDV, CHFEV, FDTRUE, R1MACH, 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 R1MACH. ! 2. CHANGED FROM FORTLIB'S RANF TO SLATEC'S RAND. ! 890629 1. Appended E0 to real constants to reduce S.P./D.P. ! differences. ! 2. Other minor cosmetic changes. ! 890831 Modified array declarations. (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) ! Also moved formats to end to be consistent with other PCHIP ! quick checks. ! 900316 Additional minor cosmetic changes. (FNF) ! 900321 Made miscellaneous 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) !***END PROLOGUE EVCHCK ! ! Declare arguments. ! subroutine EVCHCK (LOUT, KPRINT, NPTS, XEV, FEV, DEV, FEV2, FAIL) integer LOUT, KPRINT, NPTS REAL XEV(*), FEV(*), DEV(*), FEV2(*) ! ! DECLARATIONS. ! LOGICAL FAIL integer I, IERR, IINT, NEXT(2), NEXT2(2), NINT REAL 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). REAL R1MACH REAL RAND ! ! DEFINE RELATIVE ERROR WITH FLOOR. ! EXTERNAL RAND REAL RERR, ERR, VALUE, FLOOR ! ! INITIALIZE. ! RERR(ERR,VALUE,FLOOR) = ERR / max ( ABS(VALUE), FLOOR) DATA ZERO /0.E0/, ONE /1.E0/, FOUR /4.E0/, TEN /10.E0/ DATA SMALL /1.0E-10/ DATA NINT /3/ DATA LEFT /-1.5E0, 2.0E-10, 1.0E0 / ! !***FIRST EXECUTABLE STATEMENT EVCHCK DATA RIGHT / 2.5E0, 3.0E-10, 1.0E+8/ MACHEP = R1MACH(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 FDTRUE (X1, F1, D1) ! call FDTRUE (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 CHFDV (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 ! ! CHFEV SHOULD AGREE EXACTLY WITH CHFDV. ! ------- ! -------------------------------------------------------------- if ( FAILOC .and. (KPRINT >= 2)) write (LOUT, 3002) ! -------------------------------------------------------------- call CHFEV (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(ZERO) ! -------------------------------------------------------- 20 continue call CHFDV (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 FDTRUE (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 CHFEV AGREES WITH CHFDV. ! ! ----------------------------------------------------------------- end if ! ----------------------------------------------------------------- call CHFEV (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,'CHFDV ACCURACY TEST') 2001 FORMAT (10X,A2,' =',1P,E18.10,5X,A2,' =',E18.10) 2002 FORMAT (/' ERRORS AT ENDPOINTS:',40X,'(NEXT =',2I3,')' & // 1P,4X,'F1:',E13.5,4X,'F2:',E13.5, & 4X,'D1:',E13.5,4X,'D2:',E13.5) 2003 FORMAT (1P,4(7X,E13.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,2E12.4,2X,2E12.4) 2006 FORMAT ( 5X,'LOCATED AT X = ',1P,2E12.4,2X,2E12.4) 3000 FORMAT (//10X,'EVCHCK RESULTS'/10X,'--------------') 3001 FORMAT (/10X,'INTERVAL = (',1P,E12.5,',',E12.5,' ):' ) 3002 FORMAT (/' ***** CHFDV FAILED TO REPRODUCE ENDPOINT VALUES.') 3003 FORMAT (/' ***** CHFEV DOES NOT AGREE WITH CHFDV AT ENDPOINTS.') 3006 FORMAT (/' ***** MAXIMUM RELATIVE ERROR IN ',A1,' =',1P,E12.5,',' & / 17X,'EXCEEDS TOLERANCE =',E12.5) 3007 FORMAT (/' ***** ERROR ***** CHFEV RETURNED IERR =',I5) 3008 FORMAT (/' ***** CHFEV DID NOT AGREE WITH CHFDV:') 3009 FORMAT (7X,'MAXIMUM DIFFERENCE ',1P,E12.5, & '; OCCURRED AT X =',E12.5) 4003 FORMAT (/' ***** ERROR ***** CHFDV RETURNED IERR =',I5) 4006 FORMAT (/' ***** REPORTED NEXT =',2I5,' RATHER THAN 4 6') 4009 FORMAT (7X,'REPORTED NEXT =',2I3,' RATHER THAN ',2I3) 5006 FORMAT (/' CHFDV RESULTS OK.') ! -------- LAST LINE OF EVCHCK FOLLOWS ----------------------------- 5009 FORMAT (/' CHFEV AGREES WITH CHFDV.') end !! EVERCK !***SUBSIDIARY !***PURPOSE Test error returns from PCHIP evaluators for PCHQK1. !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE PRECISION (EVERCK-S, DEVERK-D) !***KEYWORDS PCHIP EVALUATOR QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! --------- CODE TO TEST ERROR RETURNS FROM PCHIP EVALUATORS. --------- ! ! ! FORTRAN LIBRARY ROUTINES USED: (WRITE). ! SLATEC LIBRARY ROUTINES USED: CHFDV, CHFEV, PCHFD, PCHFE, ! XERDMP, XGETF, XSETF. ! OTHER ROUTINES USED: COMP. ! !***ROUTINES CALLED CHFDV, CHFEV, COMP, PCHFD, PCHFE, 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). ! 890629 Appended E0 to real constants to reduce S.P./D.P. ! differences. ! 890706 Cosmetic changes to prologue. (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 EVERCK ! ! Declare arguments. ! subroutine EVERCK (LOUT, KPRINT, FAIL) integer LOUT, KPRINT ! ! DECLARATIONS. ! LOGICAL FAIL integer I, IERR, KONTRL, N, NERR, NEXT(2) REAL D(10), DUM, F(10), TEMP, X(10) ! ! INITIALIZE. ! LOGICAL COMP, SKIP !***FIRST EXECUTABLE STATEMENT EVERCK 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 CHFEV AND CHFDV. ! if ( kprint >= 2) write (LOUT, 5000) if ( kprint >= 3) write (LOUT, 5001) -1 call CHFEV (0.E0, 1.E0, 3.E0, 7.E0, 3.E0, 6.E0, 0, DUM, DUM, & NEXT, IERR) ! if ( .NOT. COMP (IERR, -1, LOUT, KPRINT) ) NERR = NERR + 1 if ( kprint >= 3) write (LOUT, 5001) -2 call CHFEV (1.E0, 1.E0, 3.E0, 7.E0, 3.E0, 6.E0, 1, DUM, DUM, & NEXT, IERR) ! if ( .NOT. COMP (IERR, -2, LOUT, KPRINT) ) NERR = NERR + 1 if ( kprint >= 3) write (LOUT, 5001) -1 call CHFDV (0.E0, 1.E0, 3.E0, 7.E0, 3.E0, 6.E0, 0, DUM, DUM, DUM, & NEXT, IERR) ! if ( .NOT. COMP (IERR, -1, LOUT, KPRINT) ) NERR = NERR + 1 if ( kprint >= 3) write (LOUT, 5001) -2 call CHFDV (1.E0, 1.E0, 3.E0, 7.E0, 3.E0, 6.E0, 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.E0 ! ! SWAP POINTS 4 AND 7, SO X-ARRAY IS OUT OF ORDER. ! 10 continue TEMP = X(4) X(4) = X(7) ! ! NOW, TEST PCHFE AND PCHFD. ! X(7) = TEMP if ( kprint >= 3) write (LOUT, 5001) -1 SKIP = .FALSE. call PCHFE (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 PCHFE (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 PCHFE (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 PCHFD (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 PCHFD (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 PCHFD (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,'EVERCK RESULTS'/10X,'--------------') 5001 FORMAT (/' THIS call SHOULD RETURN IERR =',I3) 5002 FORMAT (/' ALL ERROR RETURNS OK.') 5003 FORMAT (//' ***** TROUBLE IN EVERCK *****' & ! -------- LAST LINE OF EVERCK FOLLOWS ----------------------------- //5X,I5,' TESTS FAILED TO GIVE EXPECTED RESULTS.') end subroutine EVPCCK (LOUT, KPRINT, X, Y, F, FX, FY, XE, YE, FE, DE, & !! EVPCCK !***SUBSIDIARY !***PURPOSE Test usage of increment argument in PCHFD and PCHFE for ! PCHQK1. !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE PRECISION (EVPCCK-S, DEVPCK-D) !***KEYWORDS PCHIP EVALUATOR QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! ---- CODE TO TEST USAGE OF INCREMENT ARGUMENT IN PCHFD AND PCHFE ---- ! ! 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: PCHFD, PCHFE, R1MACH. ! !***ROUTINES CALLED PCHFD, PCHFE, R1MACH !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 820714 CONVERTED TO QUICK CHECK FOR SLATEC LIBRARY. ! 820715 1. CORRECTED SOME FORMATS. ! 2. ADDED call TO R1MACH 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. Minor cosmetic changes. ! 890407 Appended E0 to real constants to reduce S.P./D.P. ! differences. ! 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 EVPCCK ! ! Declare arguments. ! FE2, FAIL) integer LOUT, KPRINT LOGICAL FAIL REAL 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 REAL DERMAX, DERR, DTRUE, DX, FDIFF, FDIFMX, FERMAX, FERR, & FTRUE, MACHEP, TOL, PDERMX, PDIFMX, PFERMX, ZERO ! ! DEFINE TEST FUNCTION AND DERIVATIVES. ! REAL R1MACH REAL AX, AY, FCN, DFDX, DFDY FCN(AX,AY) = AX*(AY*AY)*(AX*AX + 1.E0) DFDX(AX,AY) = (AY*AY)*(3.E0*AX*AX + 1.E0) ! DFDY(AX,AY) = 2.E0*AX*AY*(AX*AX + 1.E0) DATA NMAX /10/, NX /4/, NY /6/ DATA NE /51/ ! ! INITIALIZE. ! !***FIRST EXECUTABLE STATEMENT EVPCCK DATA ZERO /0.E0/ MACHEP = R1MACH(4) ! TOL = 10.E0*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.25E0*I 1 continue X(NX) = 1.E0 DO 5 J = 1, NY Y(J) = 0.5E0*J - 1.25E0 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.E0/(NE-1) DO 8 K = 1, NE-1 XE(K) = DX*(K-1) YE(K) = 4.E0*XE(K) - 2.E0 8 continue XE(NE) = 1.E0 ! YE(NE) = 2.E0 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 PCHFD (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 ! ! PCHFE SHOULD AGREE EXACTLY WITH PCHFD. ! ! ----------------------------------------------------------- if ( kprint > 3) write (LOUT, 2001) 'X' call PCHFE (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 PCHFD (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 ! ! PCHFE SHOULD AGREE EXACTLY WITH PCHFD. ! ! ----------------------------------------------------------- if ( kprint > 3) write (LOUT, 2001) 'Y' call PCHFE (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 PCHFE AND PCHFD') 1001 FORMAT (//10X,'EVPCCK RESULTS'/10X,'--------------') 2000 FORMAT (//20X,'PCHFD 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,E15.5,0P)) 2003 FORMAT (/' ***** PCHFD AND/OR PCHFE FAILED ON ',A1,'-LINE ',I1, & ', ',A1,' =',F8.4) 2004 FORMAT (/17X,' MAXIMUM ERROR IN FUNCTION =',1P, & 1P,E13.5,0P,' (AT',F6.2,'),' & /31X, 'IN DERIVATIVE =',1P,E13.5,0P,' (AT',F6.2,').' ) 2005 FORMAT ( ' MAXIMUM DIFFERENCE BETWEEN PCHFE AND PCHFD =', & 1P,E13.5,0P,' (AT',F6.2,').' ) 2006 FORMAT (/' PCHF',A1,' RETURNED IERR = ',I2,' INSTEAD OF ',I2) 2014 FORMAT (' *** BOTH SHOULD BE <= TOL =',1P,E12.5,' ***') 3000 FORMAT (//' ***** ERROR ***** PCHFD RETURNED IERR =',I5//) 3001 FORMAT (//' ***** ERROR ***** PCHFD AND/OR PCHFE FAILED ON',I2, & 1X,A1,'-LINES.'//) ! -------- LAST LINE OF EVPCCK FOLLOWS ----------------------------- 4000 FORMAT (/' PCHFD AND PCHFE OK ON ',A1,'-LINES.') end !! F0C !***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 F0C REAL FUNCTION F0C (X) !***FIRST EXECUTABLE STATEMENT F0C REAL X F0C = 1.E0/(X*X+1.E-4) return end !! F0F !***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 F0F REAL FUNCTION F0F (X) !***FIRST EXECUTABLE STATEMENT F0F REAL X F0F = 0.0 if ( X /= 0.0) F0F = SIN(0.5E+02*X)/(X*SQRT(X)) return end !! F0O !***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 F0O REAL FUNCTION F0O (X) !***FIRST EXECUTABLE STATEMENT F0O REAL X F0O = (2.0E0*SIN(X))**14 return end !! F0S !***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 F0S REAL FUNCTION F0S (X) !***FIRST EXECUTABLE STATEMENT F0S REAL X F0S = 0.0 if ( X /= 0.0) F0S = 1.0/SQRT(X) return end !! F0WS !***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 F0WS REAL FUNCTION F0WS (X) !***FIRST EXECUTABLE STATEMENT F0WS REAL X F0WS = SIN(10.0*X) return end !! F1C !***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 F1C REAL FUNCTION F1C (X) !***FIRST EXECUTABLE STATEMENT F1C REAL X F1C = 0.0 if ( X /= 0.33) F1C = (X-0.5)*ABS(X-0.33)**(-0.9) return end !! F1F !***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 F1F REAL FUNCTION F1F (X) !***FIRST EXECUTABLE STATEMENT F1F REAL X,X1,Y X1 = X+1.0 F1F = 5.0/X1/X1 Y = 5.0/X1 if ( Y > 3.1415926535897932) F1F = 0.0 return end !! F1G !***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 F1G REAL FUNCTION F1G (X) REAL PI,X !***FIRST EXECUTABLE STATEMENT F1G DATA PI/3.1415926535897932/ F1G = 2.0/(2.0+SIN(10.0*PI*X)) return end !! F1N !***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 F1N REAL FUNCTION F1N (X) !***FIRST EXECUTABLE STATEMENT F1N REAL X F1N=1.0E0/(X**4+X**2+1.0E0) return end !! F1O !***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 F1O REAL FUNCTION F1O (X) !***FIRST EXECUTABLE STATEMENT F1O REAL X F1O = 1.0 if ( X > 3.1415926535897932) F1O = 0.0 return end !! F1P !***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 F1P REAL FUNCTION F1P (X) ! P1 = 1/7, P2 = 2/3 REAL ALFA1,ALFA2,P1,P2,X,D1,D2 DATA P1/0.1428571428571428E+00/ !***FIRST EXECUTABLE STATEMENT F1P DATA P2/0.6666666666666667E+00/ ALFA1 = -0.25E0 ALFA2 = -0.5E0 D1=ABS(X-P1) D2=ABS(X-P2) F1P = 0.0E+00 if ( D1 /= 0.0E+00 .and. D2 /= 0.0E+00) F1P = D1**ALFA1+D2**ALFA2 return end !! F1S !***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 F1S REAL FUNCTION F1S (X) !***FIRST EXECUTABLE STATEMENT F1S REAL X F1S = 0.2E+01/(0.2E+01+SIN(0.314159E+02*X)) return end !! F1WS !***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 F1WS REAL FUNCTION F1WS (X) !***FIRST EXECUTABLE STATEMENT F1WS REAL X F1WS = ABS(X-0.33E+00)**(-0.999E+00) return end !! F2G !***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 F2G REAL FUNCTION F2G (X) !***FIRST EXECUTABLE STATEMENT F2G REAL X F2G = X*SIN(0.3E+02*X)*COS(0.5E+02*X) return end !! F2N !***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 F2N REAL FUNCTION F2N (X) !***FIRST EXECUTABLE STATEMENT F2N REAL X F2N=X**(-0.9E+00) return end !! F2O !***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 F2O REAL FUNCTION F2O (X) !***FIRST EXECUTABLE STATEMENT F2O REAL X F2O = 0.0E+00 if ( X /= 0.0E+00) F2O = 1.0/(X*X*SQRT(X)) return end !! F2P !***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 F2P REAL FUNCTION F2P (X) !***FIRST EXECUTABLE STATEMENT F2P REAL X F2P = SIN(0.314159E+03*X)/(0.314159E+01*X) return end !! F2S !***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 F2S REAL FUNCTION F2S (X) !***FIRST EXECUTABLE STATEMENT F2S REAL X F2S = 100.0 if ( X /= 0.0) F2S = SIN(0.314159E+03*X)/(0.314159E+01*X) return end !! F3G !***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 F3G REAL FUNCTION F3G (X) !***FIRST EXECUTABLE STATEMENT F3G REAL X F3G = ABS(X-0.33E+00)**(-0.9E+00) return end !! F3P !***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 F3P REAL FUNCTION F3P (X) !***FIRST EXECUTABLE STATEMENT F3P REAL X F3P = 1.0 if ( X > 3.1415926535897932) F3P = 0.0 return end !! F3S !***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 F3S REAL FUNCTION F3S (X) !***FIRST EXECUTABLE STATEMENT F3S REAL X F3S = 0.1E+01 if ( X > 3.1415926535897932) F3S = 0.0 return end !! F4P !***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 F4P REAL FUNCTION F4P (X) !***FIRST EXECUTABLE STATEMENT F4P REAL X F4P = 0.0 if ( X > 0.0) F4P = 1.0/(X*SQRT(X)) return end !! F4S !***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 F4S REAL FUNCTION F4S (X) !***FIRST EXECUTABLE STATEMENT F4S REAL X if ( X == .33E+00) GO TO 10 F4S = ABS(X-0.33E+00)**(-0.999E+00) return 10 F4S=0.0 return end !! F5S !***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 F5S REAL FUNCTION F5S (X) !***FIRST EXECUTABLE STATEMENT F5S REAL X F5S = 0.0 if ( X /= 0.0) F5S = 1.0/(X*SQRT(X)) return end !! FB !***PURPOSE Subsidiary to BSPCK. !***LIBRARY SLATEC !***TYPE SINGLE 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 FB REAL FUNCTION FB (X) !***FIRST EXECUTABLE STATEMENT FB REAL X FB = 1.0E0 return end !! FCN1 !***PURPOSE Subsidiary to SNLS1Q. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (FCN1-S, DFCN1-D) !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine which evaluates the function for test program ! used in quick check of SNLS1E. ! ! Numerical approximation of Jacobian is used. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 930214 TYPE and declarations sections added. (WRB) !***END PROLOGUE FCN1 ! .. Scalar Arguments .. subroutine FCN1 (IFLAG, M, N, X, FVEC, FJAC, LDFJAC) REAL FJAC ! .. Array Arguments .. integer IFLAG, LDFJAC, M, N ! .. Local Scalars .. REAL FVEC(*), X(*) REAL TEMP, TWO ! .. Intrinsic Functions .. integer I ! .. Data statements .. INTRINSIC EXP !***FIRST EXECUTABLE STATEMENT FCN1 DATA TWO /2.0E0/ 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 !! FCN2 !***PURPOSE Subsidiary to SNLS1Q. !***LIBRARY SLATEC !***TYPE SINGLE 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 SNLS1E. ! !***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 FCN2 ! .. Scalar Arguments .. subroutine FCN2 (IFLAG, M, N, X, FVEC, FJAC, LDFJAC) ! .. Array Arguments .. integer IFLAG, LDFJAC, M, N ! .. Local Scalars .. REAL FJAC(LDFJAC,*), FVEC(*), X(*) REAL TEMP, TWO ! .. Intrinsic Functions .. integer I ! .. Data statements .. INTRINSIC EXP !***FIRST EXECUTABLE STATEMENT FCN2 DATA TWO /2.0E0/ ! ! Should we evaluate functions 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 !! FCN3 !***PURPOSE Subsidiary to SNLS1Q. !***LIBRARY SLATEC !***TYPE SINGLE 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 SNLS1E. ! !***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 FCN3 ! .. Scalar Arguments .. subroutine FCN3 (IFLAG, M, N, X, FVEC, FJROW, NROW) ! .. Array Arguments .. integer IFLAG, M, N, NROW ! .. Local Scalars .. REAL FJROW(*), FVEC(*), X(*) REAL TEMP, TWO ! .. Intrinsic Functions .. integer I ! .. Data statements .. INTRINSIC EXP !***FIRST EXECUTABLE STATEMENT FCN3 DATA TWO /2.0E0/ ! ! Should we evaluate functions 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 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 !! FCNQX1 !***SUBSIDIARY !***PURPOSE THIS IS A QUICK CHECK PROGRAM FOR THE SUBROUTINES XLEGF ! AND XNRMP WHICH CALCULATE LEGENDRE FUNCTIONS !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE SINGLE PRECISION (FCNQX1-S, FCNQX2-D) !***KEYWORDS LEGENDRE FUNCTIONS, QUICK CHECK !***AUTHOR LOZIER, DANIEL W., (NIST) ! SMITH, JOHN M., (NIST AND GEORGE MASON UNIVERSITY) !***REFERENCES OLVER AND SMITH,J.COMPUT.PHYSICS,51(1983),NO.3,502-518. ! SMITH, OLVER AND LOZIER,ACM TRANS MATH SOFTW,7(1981), ! NO.1,93-105. !***ROUTINES CALLED XCON, XCSRT, XERCLR, XLEGF, XNRMP, XSET, XSETF !***REVISION HISTORY (YYMMDD) ! 881020 DATE WRITTEN ! 900306 Added SLATEC prologue to this routine. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! 910104 Changed to print variable number of decimals. (DWL and JMS) !***END PROLOGUE FCNQX1 ! subroutine FCNQX1 (LUN, KPRINT, IPASS) CHARACTER*34 FMT, FMTF, FMTI integer lun, kprint, ipass dimension P(10),Q(10),R(10),C1(10),C2(10),IP(10),IQ(10),IR(10) dimension IC1(10),IC2(10),PN(10),IPN(10) REAL P,Q,R,C1,C2,PN REAL DEG,THETA,DNU1,DZERO REAL X11,X12,X13,X21,X22,X23 ! !***FIRST EXECUTABLE STATEMENT FCNQX1 ! REAL NU if ( KPRINT >= 2) WRITE(LUN,1) 1 FORMAT(' ** TEST SINGLE PRECISION LEGENDRE FUNCTION ROUTINES', & ' IN FCNPAK ** ',/) IPASS=1 IRAD=0 NRADPL=0 DZERO=0.0 NBITS=0 call XSET(IRAD,NRADPL,DZERO,NBITS,IERROR) if ( IERROR /= 0) IPASS=0 IERR=0 DNU1=2000.4 if ( i1mach(13)*LOG10(REAL(i1mach(10))) < 150.) DNU1=100.4 if ( kprint <= 2) GO TO 150 if ( i1mach(13) < 500) WRITE(LUN,24) 24 FORMAT(' ON COMPUTERS WITH MAXIMUM EXPONENT LESS THAN 500, SMALL'/ & ' TEST VALUES FOR NU, MU ARE USED. IF LARGER THAN OR EQUAL 500,'/ & ' LARGER VALUES ARE USED. THIS COMPUTER USES THE SMALLER VALUES.') if ( i1mach(13) >= 500) WRITE(LUN,26) 26 FORMAT(' ON COMPUTERS WITH MAXIMUM EXPONENT LESS THAN 500, SMALL'/ & ' TEST VALUES FOR NU, MU ARE USED. IF LARGER THAN OR EQUAL 500,'/ & ' LARGER VALUES ARE USED. THIS COMPUTER USES THE LARGER VALUES.') 150 continue NUDIFF=5 MU1=DNU1 MU2=MU1 DEG=0.1 ! ! In TEST 1 the Legendre functions P (of both positive and negative ! order) and Q are calculated. Large values of mu and nu are used ! so that it is necessary to use extended range arithmetic. The ! values of the Casoratians should be approximately equal to 1.0. ! The check which is applied is to verify that the difference between ! the Casoratians and 1.0 is less that 10.**(6-NDEC), where NDEC = ! INT((D-1)*LOG10(R)), D = i1mach(11) = significand length, R = ! i1mach(10) = radix. The value of IERROR should always be returned ! as zero. This test uses the programs ! XLEGF, XPQNU, XPSI, XQNU, XPMUP, XSET, XADD, ! XADJ, XCSRT, XRED, XC210, and XCON. ! THETA=DEG*4.*ATAN(1.0)/180.0 ISUM=0 ! Formats that depend on NDEC ... NDEC = (i1mach(11)-1) * LOG10(REAL(i1mach(10))) FMT(1:20)='(1X, 6X, 4H (,E30.' write (FMT(21:22),'(I2)') NDEC FMT(23:34)=',1H,,I8,1H))' FMTF(1:20)='(1X,F6.1,4H (,E30.' write (FMTF(21:22),'(I2)') NDEC FMTF(23:34)=',1H,,I8,1H))' FMTI(1:20)='(1X, I6, 4H (,E30.' write (FMTI(21:22),'(I2)') NDEC FMTI(23:34)=',1H,,I8,1H))' if ( kprint > 2) WRITE(LUN,2) MU1, DEG 2 FORMAT(/ & ' TEST 1, FIXED MU = ',I4,' AND THETA = ',F3.1, & ' DEGREES, RECURRENCE IN NU,'/ & ' CASORATIS SHOULD = 1.0') call XLEGF(DNU1,NUDIFF,MU1,MU2,THETA,1,P,IP,IERROR) ISUM=ISUM+IERROR call XLEGF(DNU1,NUDIFF,MU1,MU2,THETA,2,Q,IQ,IERROR) ISUM=ISUM+IERROR call XLEGF(DNU1,NUDIFF,MU1,MU2,THETA,3,R,IR,IERROR) ISUM=ISUM+IERROR call XCSRT(DNU1,NUDIFF,MU1,MU2,THETA,P,Q,R,IP,IQ,IR, & C1,IC1,C2,IC2,IERROR) ISUM=ISUM+IERROR DO 20 I=1,6 call XCON(P(I),IP(I),IERROR) ISUM=ISUM+IERROR call XCON(Q(I),IQ(I),IERROR) ISUM=ISUM+IERROR call XCON(R(I),IR(I),IERROR) ISUM=ISUM+IERROR 20 continue X11=P(1) IX11=IP(1) X12=R(1) IX12=IR(1) X13=Q(1) IX13=IQ(1) if ( kprint > 2 ) then write (LUN,'(A)') ' NU CASORATI 1' NU=DNU1 DO 25 I=1,5 write (LUN,FMTF) NU,C1(I),IC1(I) NU=NU+1. 25 continue write (LUN,'(A)') ' NU CASORATI 2' NU=DNU1 DO 30 I=1,5 write (LUN,FMTF) NU,C2(I),IC2(I) NU=NU+1. 30 continue end if DO 35 I=1,5 if ( ABS(1.0-C1(I)) >= 10.0E0**(6-NDEC)) GO TO 40 if ( ABS(1.0-C2(I)) >= 10.0E0**(6-NDEC)) GO TO 40 35 continue if ( ISUM /= 0) GO TO 40 if ( KPRINT >= 2) WRITE(LUN,8) 8 FORMAT(' ***** TEST 1 (SINGLE PRECISION) PASSED *****') GO TO 50 40 if ( KPRINT >= 1) WRITE(LUN,7) 7 FORMAT(' ***** TEST 1 (SINGLE PRECISION) FAILED *****') IERR=IERR+1 IPASS=0 50 NUDIFF=0 ! ! In TEST 2 P (of positive and negative order) and Q are again ! calculated but in this test the recurrence is in the mu-wise direction ! rather than in the nu-wise direction as was the case before. The same ! programs are used except that XQNU is not used and XQMU and XPMU ! are used. Again the criterion for passing the test is that the ! Casoratians differ from 1.0 by less than 10.0**(6-NDEC). The value ! of IERROR should always be returned as zero. ! MU1=MU2-5 ISUM=0 if ( kprint > 2) WRITE(LUN,9) DNU1, DEG 9 FORMAT(/ & ' TEST 2, FIXED NU = ',F6.1,' AND THETA = ',F3.1, & ' DEGREES, RECURRENCE IN MU,'/ & ' CASORATIS SHOULD = 1.0') call XLEGF(DNU1,NUDIFF,MU1,MU2,THETA,1,P,IP,IERROR) ISUM=ISUM+IERROR call XLEGF(DNU1,NUDIFF,MU1,MU2,THETA,2,Q,IQ,IERROR) ISUM=ISUM+IERROR call XLEGF(DNU1,NUDIFF,MU1,MU2,THETA,3,R,IR,IERROR) ISUM=ISUM+IERROR call XCSRT(DNU1,NUDIFF,MU1,MU2,THETA,P,Q,R,IP,IQ,IR, & C1,IC1,C2,IC2,IERROR) ISUM=ISUM+IERROR DO 60 I=1,6 call XCON(P(I),IP(I),IERROR) ISUM=ISUM+IERROR call XCON(Q(I),IQ(I),IERROR) ISUM=ISUM+IERROR call XCON(R(I),IR(I),IERROR) ISUM=ISUM+IERROR 60 continue X21=P(6) IX21=IP(6) X22=R(6) IX22=IR(6) X23=Q(6) IX23=IQ(6) if ( kprint > 2 ) then write (LUN,'(A)') ' MU CASORATI 3' MU=MU1 DO 65 I=1,5 write (LUN,FMTI) MU,C1(I),IC1(I) MU=MU+1 65 continue write (LUN,'(A)') ' MU CASORATI 4' MU=MU1 DO 70 I=1,5 write (LUN,FMTI) MU,C2(I),IC2(I) MU=MU+1 70 continue end if DO 75 I=1,5 if ( ABS(1.0-C1(I)) >= 10.0E0**(6-NDEC)) GO TO 80 if ( ABS(1.0-C2(I)) >= 10.0E0**(6-NDEC)) GO TO 80 if ( ISUM /= 0) GO TO 80 75 continue if ( KPRINT >= 2) WRITE(LUN,12) 12 FORMAT(' ***** TEST 2 (SINGLE PRECISION) PASSED *****') GO TO 85 80 if ( KPRINT >= 1) WRITE(LUN,11) 11 FORMAT(' ***** TEST 2 (SINGLE PRECISION) FAILED *****') IERR=IERR+1 ! ! In TEST 3 values of P and Q which were calculated in two different ! manners, one by nu-wise recurrence in TEST 1 and one by mu-wise ! recurrence in TEST 2, are compared. Again, the criterion for success ! is a relative error of less than 10.0**(6-NDEC). ! IPASS=0 85 if ( kprint > 2 ) then write (LUN,13) DEG, MU2, DNU1 13 FORMAT(/ & ' TEST 3, COMPARISON OF VALUES FROM TEST 1 AND TEST 2', & ' WITH THETA = ',F3.1,' DEGREES,'/ & ' MU = ',I4,' AND NU = ',F6.1) write (LUN,'(A)') ' P(-MU,NU)' write (LUN,FMT) X11,IX11 write (LUN,FMT) X21,IX21 write (LUN,'(A)') ' P(MU,NU)' write (LUN,FMT) X12,IX12 write (LUN,FMT) X22,IX22 write (LUN,'(A)') ' Q(MU,NU)' write (LUN,FMT) X13,IX13 write (LUN,FMT) X23,IX23 end if if ( ABS((X11-X21)/X11) >= 10.0E0**(6-NDEC)) GO TO 90 if ( ABS((X12-X22)/X12) >= 10.0E0**(6-NDEC)) GO TO 90 if ( ABS((X13-X13)/X13) >= 10.0E0**(6-NDEC)) GO TO 90 if ( IX11 /= IX21) GO TO 90 if ( IX12 /= IX22) GO TO 90 if ( IX13 /= IX23) GO TO 90 if ( KPRINT >= 2) WRITE(LUN,15) 15 FORMAT(' ***** TEST 3 (SINGLE PRECISION) PASSED *****') GO TO 100 90 if ( KPRINT >= 1) WRITE(LUN,16) 16 FORMAT(' ***** TEST 3 (SINGLE PRECISION) FAILED *****') IERR=IERR+1 IPASS=0 ! ! In TEST 4, the value of the normalized Legendre function as ! calculated by XLEGF and XPNRM is compared to the same value ! as calculated by the program XNRMP. Again the criterion is a ! relative error of less than 10.0**(6-NDEC). The value of IERROR ! should always be returned as zero. ! 100 continue ISUM=0 DNU1=100.0 NUDIFF=0 MU1=10 MU2=10 if ( kprint > 2) WRITE(LUN,17) DEG, MU1, DNU1 17 FORMAT(/ & ' TEST 4, COMPARISON OF VALUES FROM XLEGF AND XNRMP', & ' WITH THETA = ',F3.1,' DEGREES,'/ & ' MU = ',I4,' AND NU = ',F6.1) call XLEGF(DNU1,NUDIFF,MU1,MU2,THETA,4,PN,IPN,IERROR) ISUM=ISUM+IERROR X11=PN(1) IX11=IPN(1) NU1=100 call XNRMP(NU1,MU1,MU2,THETA,2,PN,IPN,ISIG,IERROR) ISUM=ISUM+IERROR X21=PN(1) IX21=IPN(1) if ( kprint > 2 ) then write (LUN,'(A)') ' NORMALIZED P' write (LUN,FMT) X11,IX11 write (LUN,FMT) X21,IX21 end if if ( ABS((X11-X21)/X11) >= 10.0E0**(6-NDEC)) GO TO 110 if ( IX11 /= IX21) GO TO 110 if ( ISUM /= 0) GO TO 110 if ( KPRINT >= 2) WRITE(LUN,18) 18 FORMAT(' ***** TEST 4 (SINGLE PRECISION) PASSED *****') GO TO 120 110 if ( KPRINT >= 1) WRITE(LUN,19) 19 FORMAT(' ***** TEST 4 (SINGLE PRECISION) FAILED *****') IERR=IERR+1 IPASS=0 ! ! In TEST 5 errors are purposely made in input so as to test error ! handling capability. First, an incorrect value of ID is given. Then ! both NUDIFF and MU2-MU1 are non-zero. Finally, an incorrect value ! of THETA is given. In each case the value of the error indicator ! IERROR should equal the error number as returned by the error ! handling package XERROR (which includes XSETF, XERCLR, and NUMXER). ! 120 continue call xsetf ( -1 ) if ( kprint <= 2) call xsetf ( 0 ) if ( kprint > 2) WRITE(LUN,23) 23 FORMAT(/' TEST 5, TEST OF ERROR HANDLING. 3 ERROR MESSAGES', & ' SHOULD BE PRINTED.') NUDIFF=0 MU2=MU1 ID=5 call xerclr call XLEGF(DNU1,NUDIFF,MU1,MU2,THETA,ID,P,IP,IERROR) N=NUMXER(NERR) if ( N /= IERROR) GO TO 125 MU2=MU1+5 NUDIFF=5 call xerclr call XLEGF(DNU1,NUDIFF,MU1,MU2,THETA,1,P,IP,IERROR) N=NUMXER(NERR) if ( N /= IERROR) GO TO 125 NUDIFF=0 THETA=2.0 call xerclr call XLEGF(DNU1,NUDIFF,MU1,MU2,THETA,1,P,IP,IERROR) N=NUMXER(NERR) if ( N /= IERROR) GO TO 125 if ( KPRINT >= 2) WRITE(LUN,28) 28 FORMAT(' ***** TEST 5 (SINGLE PRECISION) PASSED *****') GO TO 135 125 if ( KPRINT >= 1) WRITE(LUN,29) 29 FORMAT(' ***** TEST 5 (SINGLE PRECISION) FAILED *****') IERR=IERR+1 IPASS=0 135 continue if ( IERR == 0) GO TO 140 if ( KPRINT >= 2) WRITE(LUN,21) IERR 21 FORMAT(/' TESTS COMPLETED, NUMBER OF TESTS FAILED = ',I2) 140 continue return end !! FCNQX2 !***SUBSIDIARY !***PURPOSE THIS IS A QUICK CHECK PROGRAM FOR THE SUBROUTINES DXLEGF ! AND DXNRMP WHICH CALCULATE LEGENDRE FUNCTIONS !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE DOUBLE PRECISION (FCNQX1-S, FCNQX2-D) !***KEYWORDS LEGENDRE FUNCTIONS, QUICK CHECK !***AUTHOR LOZIER, DANIEL W., (NIST) ! SMITH, JOHN M., (NIST AND GEORGE MASON UNIVERSITY) !***REFERENCES OLVER AND SMITH,J.COMPUT.PHYSICS,51(1983),NO.3,502-518. ! SMITH, OLVER AND LOZIER,ACM TRANS MATH SOFTW,7(1981), ! NO.1,93-105. !***ROUTINES CALLED DXCON, DXCSRT, XERCLR, DXLEGF, DXNRMP, DXSET, XSETF !***REVISION HISTORY (YYMMDD) ! 881020 DATE WRITTEN ! 900306 Added SLATEC prologue to this routine. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) ! 910104 Changed to print variable number of decimals. (DWL and JMS) !***END PROLOGUE FCNQX2 ! subroutine FCNQX2 (LUN, KPRINT, IPASS) CHARACTER*34 FMT, FMTF, FMTI integer lun, kprint, ipass dimension P(10),Q(10),R(10),C1(10),C2(10),IP(10),IQ(10),IR(10) dimension IC1(10),IC2(10),PN(10),IPN(10) double precision P,Q,R,C1,C2,PN double precision DEG,THETA,DNU1,DZERO double precision X11,X12,X13,X21,X22,X23 ! !***FIRST EXECUTABLE STATEMENT FCNQX2 ! REAL NU if ( KPRINT >= 2) WRITE(LUN,1) 1 FORMAT(' ** TEST DOUBLE PRECISION LEGENDRE FUNCTION ROUTINES', & ' IN FCNPAK ** ',/) IPASS=1 IRAD=0 NRADPL=0 DZERO=0.0D0 NBITS=0 call DXSET(IRAD,NRADPL,DZERO,NBITS,IERROR) if ( IERROR /= 0) IPASS=0 IERR=0 DNU1=2000.4D0 if ( i1mach(16)*LOG10(REAL(i1mach(10))) < 150.) DNU1=100.4D0 if ( kprint <= 2) GO TO 150 if ( i1mach(16) < 500) WRITE(LUN,24) 24 FORMAT(' ON COMPUTERS WITH MAXIMUM EXPONENT LESS THAN 500, SMALL'/ & ' TEST VALUES FOR NU, MU ARE USED. IF LARGER THAN OR EQUAL 500,'/ & ' LARGER VALUES ARE USED. THIS COMPUTER USES THE SMALLER VALUES.') if ( i1mach(16) >= 500) WRITE(LUN,26) 26 FORMAT(' ON COMPUTERS WITH MAXIMUM EXPONENT LESS THAN 500, SMALL'/ & ' TEST VALUES FOR NU, MU ARE USED. IF LARGER THAN OR EQUAL 500,'/ & ' LARGER VALUES ARE USED. THIS COMPUTER USES THE LARGER VALUES.') 150 continue NUDIFF=5 MU1=DNU1 MU2=MU1 DEG=0.1D0 ! ! In TEST 1 the Legendre functions P (of both positive and negative ! order) and Q are calculated. Large values of mu and nu are used ! so that it is necessary to use extended range arithmetic. The ! values of the Casoratians should be approximately equal to 1.0. ! The check which is applied is to verify that the difference between ! the Casoratians and 1.0 is less that 10.**(6-NDEC), where NDEC = ! INT((D-1)*LOG10(R)), D = i1mach(14) = significand length, R = ! i1mach(10) = radix. The value of IERROR should always be returned ! as zero. This test uses the programs ! XLEGF, XPQNU, XPSI, XQNU, XPMUP, XSET, XADD, ! XADJ, XCSRT, XRED, XC210, and XCON. ! THETA=DEG*4.D0*ATAN(1.0D0)/180.0D0 ISUM=0 ! Formats that depend on NDEC ... NDEC = (i1mach(14)-1) * LOG10(REAL(i1mach(10))) FMT(1:20)='(1X, 6X, 4H (,E50.' write (FMT(21:22),'(I2)') NDEC FMT(23:34)=',1H,,I8,1H))' FMTF(1:20)='(1X,F6.1,4H (,E50.' write (FMTF(21:22),'(I2)') NDEC FMTF(23:34)=',1H,,I8,1H))' FMTI(1:20)='(1X, I6, 4H (,E50.' write (FMTI(21:22),'(I2)') NDEC FMTI(23:34)=',1H,,I8,1H))' if ( kprint > 2) WRITE(LUN,2) MU1, DEG 2 FORMAT(/ & ' TEST 1, FIXED MU = ',I4,' AND THETA = ',F3.1, & ' DEGREES, RECURRENCE IN NU,'/ & ' CASORATIS SHOULD = 1.0') call DXLEGF(DNU1,NUDIFF,MU1,MU2,THETA,1,P,IP,IERROR) ISUM=ISUM+IERROR call DXLEGF(DNU1,NUDIFF,MU1,MU2,THETA,2,Q,IQ,IERROR) ISUM=ISUM+IERROR call DXLEGF(DNU1,NUDIFF,MU1,MU2,THETA,3,R,IR,IERROR) ISUM=ISUM+IERROR call DXCSRT(DNU1,NUDIFF,MU1,MU2,THETA,P,Q,R,IP,IQ,IR, & C1,IC1,C2,IC2,IERROR) ISUM=ISUM+IERROR DO 20 I=1,6 call DXCON(P(I),IP(I),IERROR) ISUM=ISUM+IERROR call DXCON(Q(I),IQ(I),IERROR) ISUM=ISUM+IERROR call DXCON(R(I),IR(I),IERROR) ISUM=ISUM+IERROR 20 continue X11=P(1) IX11=IP(1) X12=R(1) IX12=IR(1) X13=Q(1) IX13=IQ(1) if ( kprint > 2 ) then write (LUN,'(A)') ' NU CASORATI 1' NU=DNU1 DO 25 I=1,5 write (LUN,FMTF) NU,C1(I),IC1(I) NU=NU+1. 25 continue write (LUN,'(A)') ' NU CASORATI 2' NU=DNU1 DO 30 I=1,5 write (LUN,FMTF) NU,C2(I),IC2(I) NU=NU+1. 30 continue end if DO 35 I=1,5 if ( ABS(1.0D0-C1(I)) >= 10.0D0**(6-NDEC)) GO TO 40 if ( ABS(1.0D0-C2(I)) >= 10.0D0**(6-NDEC)) GO TO 40 35 continue if ( ISUM /= 0) GO TO 40 if ( KPRINT >= 2) WRITE(LUN,8) 8 FORMAT(' ***** TEST 1 (DOUBLE PRECISION) PASSED *****') GO TO 50 40 if ( KPRINT >= 1) WRITE(LUN,7) 7 FORMAT(' ***** TEST 1 (DOUBLE PRECISION) FAILED *****') IERR=IERR+1 IPASS=0 50 NUDIFF=0 ! ! In TEST 2 P (of positive and negative order) and Q are again ! calculated but in this test the recurrence is in the mu-wise direction ! rather than in the nu-wise direction as was the case before. The same ! programs are used except that DXQNU is not used and DXQMU and DXPMU ! are used. Again the criterion for passing the test is that the ! Casoratians differ from 1.0 by less than 10.0**(6-NDEC). The value ! of IERROR should always be returned as zero. ! MU1=MU2-5 ISUM=0 if ( kprint > 2) WRITE(LUN,9) DNU1, DEG 9 FORMAT(/ & ' TEST 2, FIXED NU = ',F6.1,' AND THETA = ',F3.1, & ' DEGREES, RECURRENCE IN MU,'/ & ' CASORATIS SHOULD = 1.0') call DXLEGF(DNU1,NUDIFF,MU1,MU2,THETA,1,P,IP,IERROR) ISUM=ISUM+IERROR call DXLEGF(DNU1,NUDIFF,MU1,MU2,THETA,2,Q,IQ,IERROR) ISUM=ISUM+IERROR call DXLEGF(DNU1,NUDIFF,MU1,MU2,THETA,3,R,IR,IERROR) ISUM=ISUM+IERROR call DXCSRT(DNU1,NUDIFF,MU1,MU2,THETA,P,Q,R,IP,IQ,IR, & C1,IC1,C2,IC2,IERROR) ISUM=ISUM+IERROR DO 60 I=1,6 call DXCON(P(I),IP(I),IERROR) ISUM=ISUM+IERROR call DXCON(Q(I),IQ(I),IERROR) ISUM=ISUM+IERROR call DXCON(R(I),IR(I),IERROR) ISUM=ISUM+IERROR 60 continue X21=P(6) IX21=IP(6) X22=R(6) IX22=IR(6) X23=Q(6) IX23=IQ(6) if ( kprint > 2 ) then write (LUN,'(A)') ' MU CASORATI 3' MU=MU1 DO 65 I=1,5 write (LUN,FMTI) MU,C1(I),IC1(I) MU=MU+1 65 continue write (LUN,'(A)') ' MU CASORATI 4' MU=MU1 DO 70 I=1,5 write (LUN,FMTI) MU,C2(I),IC2(I) MU=MU+1 70 continue end if DO 75 I=1,5 if ( ABS(1.0D0-C1(I)) >= 10.0D0**(6-NDEC)) GO TO 80 if ( ABS(1.0D0-C2(I)) >= 10.0D0**(6-NDEC)) GO TO 80 if ( ISUM /= 0) GO TO 80 75 continue if ( KPRINT >= 2) WRITE(LUN,12) 12 FORMAT(' ***** TEST 2 (DOUBLE PRECISION) PASSED *****') GO TO 85 80 if ( KPRINT >= 1) WRITE(LUN,11) 11 FORMAT(' ***** TEST 2 (DOUBLE PRECISION) FAILED *****') IERR=IERR+1 ! ! In TEST 3 values of P and Q which were calculated in two different ! manners, one by nu-wise recurrence in TEST 1 and one by mu-wise ! recurrence in TEST 2, are compared. Again, the criterion for success ! is a relative error of less than 10.0**(6-NDEC). ! IPASS=0 85 if ( kprint > 2 ) then write (LUN,13) DEG, MU2, DNU1 13 FORMAT(/ & ' TEST 3, COMPARISON OF VALUES FROM TEST 1 AND TEST 2', & ' WITH THETA = ',F3.1,' DEGREES,'/ & ' MU = ',I4,' AND NU = ',F6.1) write (LUN,'(A)') ' P(-MU,NU)' write (LUN,FMT) X11,IX11 write (LUN,FMT) X21,IX21 write (LUN,'(A)') ' P(MU,NU)' write (LUN,FMT) X12,IX12 write (LUN,FMT) X22,IX22 write (LUN,'(A)') ' Q(MU,NU)' write (LUN,FMT) X13,IX13 write (LUN,FMT) X23,IX23 end if if ( ABS((X11-X21)/X11) >= 10.0D0**(6-NDEC)) GO TO 90 if ( ABS((X12-X22)/X12) >= 10.0D0**(6-NDEC)) GO TO 90 if ( ABS((X13-X23)/X13) >= 10.0D0**(6-NDEC)) GO TO 90 if ( IX11 /= IX21) GO TO 90 if ( IX12 /= IX22) GO TO 90 if ( IX13 /= IX23) GO TO 90 if ( KPRINT >= 2) WRITE(LUN,15) 15 FORMAT(' ***** TEST 3 (DOUBLE PRECISION) PASSED *****') GO TO 100 90 if ( KPRINT >= 1) WRITE(LUN,16) 16 FORMAT(' ***** TEST 3 (DOUBLE PRECISION) FAILED *****') IERR=IERR+1 IPASS=0 ! ! In TEST 4, the value of the normalized Legendre function as ! calculated by DXLEGF and DXPNRM is compared to the same value ! as calculated by the program DXNRMP. Again the criterion is a ! relative error of less than 10.0**(6-NDEC). The value of IERROR ! should always be returned as zero. ! 100 continue ISUM=0 DNU1=100.0D0 NUDIFF=0 MU1=10 MU2=10 if ( kprint > 2) WRITE(LUN,17) DEG, MU1, DNU1 17 FORMAT(/ & ' TEST 4, COMPARISON OF VALUES FROM DXLEGF AND DXNRMP', & ' WITH THETA = ',F3.1,' DEGREES,'/ & ' MU = ',I4,' AND NU = ',F6.1) call DXLEGF(DNU1,NUDIFF,MU1,MU2,THETA,4,PN,IPN,IERROR) ISUM=ISUM+IERROR X11=PN(1) IX11=IPN(1) NU1=100 call DXNRMP(NU1,MU1,MU2,THETA,2,PN,IPN,ISIG,IERROR) ISUM=ISUM+IERROR X21=PN(1) IX21=IPN(1) if ( kprint > 2 ) then write (LUN,'(A)') ' NORMALIZED P' write (LUN,FMT) X11,IX11 write (LUN,FMT) X21,IX21 end if if ( ABS((X11-X21)/X11) >= 10.0D0**(6-NDEC)) GO TO 110 if ( IX11 /= IX21) GO TO 110 if ( ISUM /= 0) GO TO 110 if ( KPRINT >= 2) WRITE(LUN,18) 18 FORMAT(' ***** TEST 4 (DOUBLE PRECISION) PASSED *****') GO TO 120 110 if ( KPRINT >= 1) WRITE(LUN,19) 19 FORMAT(' ***** TEST 4 (DOUBLE PRECISION) FAILED *****') IERR=IERR+1 IPASS=0 ! ! In TEST 5 errors are purposely made in input so as to test error ! handling capability. First, an incorrect value of ID is given. Then ! both NUDIFF and MU2-MU1 are non-zero. Finally, an incorrect value ! of THETA is given. In each case the value of the error indicator ! IERROR should equal the error number as returned by the error ! handling package XERROR (which includes XSETF, XERCLR, and NUMXER). ! 120 continue call xsetf ( -1 ) if ( kprint <= 2) call xsetf ( 0 ) if ( kprint > 2) WRITE(LUN,23) 23 FORMAT(/' TEST 5, TEST OF ERROR HANDLING. 3 ERROR MESSAGES', & ' SHOULD BE PRINTED.') NUDIFF=0 MU2=MU1 ID=5 call xerclr call DXLEGF(DNU1,NUDIFF,MU1,MU2,THETA,ID,P,IP,IERROR) N=NUMXER(NERR) if ( N /= IERROR) GO TO 125 MU2=MU1+5 NUDIFF=5 call xerclr call DXLEGF(DNU1,NUDIFF,MU1,MU2,THETA,1,P,IP,IERROR) N=NUMXER(NERR) if ( N /= IERROR) GO TO 125 NUDIFF=0 THETA=2.0D0 call xerclr call DXLEGF(DNU1,NUDIFF,MU1,MU2,THETA,1,P,IP,IERROR) N=NUMXER(NERR) if ( N /= IERROR) GO TO 125 if ( KPRINT >= 2) WRITE(LUN,28) 28 FORMAT(' ***** TEST 5 (DOUBLE PRECISION) PASSED *****') GO TO 135 125 if ( KPRINT >= 1) WRITE(LUN,29) 29 FORMAT(' ***** TEST 5 (DOUBLE PRECISION) FAILED *****') IERR=IERR+1 IPASS=0 135 continue if ( IERR == 0) GO TO 140 if ( KPRINT >= 2) WRITE(LUN,21) IERR 21 FORMAT(/' TESTS COMPLETED, NUMBER OF TESTS FAILED = ',I2) 140 continue return end !! FCQX !***PURPOSE Quick check for FC. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (FCQX-S, DFCQX-D) !***KEYWORDS QUICK CHECK !***AUTHOR Hanson, R. J., (SNLA) !***DESCRIPTION ! ! Quick check subprogram for the subroutine FC. ! ! Fit discrete data by an S-shaped curve. Evaluate the fitted curve, ! its first two derivatives, and probable error curve. ! ! Use subprogram FC to obtain the constrained cubic B-spline ! representation of the curve. ! ! The values of the coefficients of the B-spline as computed by FC ! and the values of the fitted curve as computed by BVALU 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 BVALU, CV, FC, IVOUT, R1MACH, SCOPY, SMOUT, SVOUT !***REVISION HISTORY (YYMMDD) ! 780801 DATE WRITTEN ! 890718 Changed references from BVALUE to BVALU. (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 R1MACH(4) rather than R1MACH(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 FCQX ! .. Scalar Arguments .. subroutine FCQX (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN REAL 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 REAL 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) REAL BVALU, CV, R1MACH integer NUMXER ! .. External Subroutines .. EXTERNAL BVALU, CV, NUMXER, R1MACH ! .. Intrinsic Functions .. EXTERNAL FC, IVOUT, SCOPY, SMOUT, SVOUT, XGETF, XSETF ! .. Data statements .. ! INTRINSIC ABS, REAL, SQRT DATA XDATA(1),XDATA(2),XDATA(3),XDATA(4),XDATA(5),XDATA(6), & XDATA(7),XDATA(8),XDATA(9) & /0.15E0,0.27E0,0.33E0,0.40E0,0.43E0,0.47E0, & 0.53E0,0.58E0,0.63E0/ DATA YDATA(1),YDATA(2),YDATA(3),YDATA(4),YDATA(5),YDATA(6), & YDATA(7),YDATA(8),YDATA(9) & /0.025E0,0.05E0,0.13E0,0.27E0,0.37E0,0.47E0, & 0.64E0,0.77E0,0.87E0/ DATA SDDATA(1)/0.015E0/, 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.6E0,-0.4E0,-0.2E0,0.0E0,0.2E0,0.4E0,0.6E0, & ! ! Store the data to be used to check the accuracy of the computed ! results. See SAND78-1291, p.26. ! 0.8E0,0.9E0,1.0E0,1.1E0,1.2E0,1.3E0/ DATA COEFCK(1),COEFCK(2),COEFCK(3),COEFCK(4),COEFCK(5),COEFCK(6), & COEFCK(7),COEFCK(8),COEFCK(9) & /1.186380846E-13,-2.826166426E-14,-4.333929094E-15, & 1.722113311E-01, 9.421965984E-01, 9.684708719E-01, & 9.894902905E-01, 1.005254855E+00, 9.894902905E-01/ DATA CHECK(1),CHECK(2),CHECK(3),CHECK(4),CHECK(5),CHECK(6), & CHECK(7),CHECK(8),CHECK(9) & /2.095830752E-16, 2.870188850E-05, 2.296151081E-04, & 7.749509897E-04, 1.836920865E-03, 3.587736064E-03, & 6.199607918E-03, 9.844747759E-03, 1.469536692E-02/ DATA CHECK(10),CHECK(11),CHECK(12),CHECK(13),CHECK(14),CHECK(15), & CHECK(16),CHECK(17),CHECK(18) & /2.092367672E-02, 2.870188851E-02, 3.824443882E-02, & 4.993466504E-02, 6.419812979E-02, 8.146039566E-02, & 1.021470253E-01, 1.266835812E-01, 1.554956261E-01/ DATA CHECK(19),CHECK(20),CHECK(21),CHECK(22),CHECK(23),CHECK(24), & CHECK(25),CHECK(26),CHECK(27) & /1.890087225E-01, 2.276484331E-01, 2.718403204E-01, & 3.217163150E-01, 3.762338189E-01, 4.340566020E-01, & 4.938484342E-01, 5.542730855E-01,6.139943258E-01/ DATA CHECK(28),CHECK(29),CHECK(30),CHECK(31),CHECK(32),CHECK(33), & CHECK(34),CHECK(35),CHECK(36) & /6.716759250E-01, 7.259816530E-01, 7.755752797E-01, & 8.191205752E-01, 8.556270903E-01, 8.854875002E-01, & 9.094402609E-01, 9.282238286E-01, 9.425766596E-01/ DATA CHECK(37),CHECK(38),CHECK(39),CHECK(40),CHECK(41),CHECK(42), & CHECK(43),CHECK(44),CHECK(45) & /9.532372098E-01, 9.609439355E-01, 9.664352927E-01, & 9.704497377E-01, 9.737257265E-01, 9.768786393E-01, & 9.800315521E-01, 9.831844649E-01, 9.863373777E-01/ DATA CHECK(46),CHECK(47),CHECK(48),CHECK(49),CHECK(50), & CHECK(51) & /9.894902905E-01, 9.926011645E-01, 9.954598055E-01, & !***FIRST EXECUTABLE STATEMENT FCQX 9.978139804E-01, 9.994114563E-01, 1.000000000E+00/ if ( kprint >= 2) write (LUN,9000) ! ! Broadcast SDDATA(1) value to all of SDDATA(*). ! ipass = 1 call SCOPY(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 SVOUT (NBKPT,BKPT,'('' ARRAY OF KNOTS.'')',IDIGIT) call SVOUT (NDATA,XDATA, & '('' INDEPENDENT VARIABLE VALUES'')',IDIGIT) call SVOUT (NDATA,YDATA,'('' DEPENDENT VARIABLE VALUES'')', & IDIGIT) call SVOUT (NDATA,SDDATA, & '('' DEPENDENT VARIABLE UNCERTAINTY'')',IDIGIT) call SVOUT (NCONST,XCONST, & '('' INDEPENDENT VARIABLE CONSTRAINT VALUES'')', & IDIGIT) call SVOUT (NCONST,YCONST,'('' CONSTRAINT VALUES'')',IDIGIT) call IVOUT (NCONST,NDERIV,'('' CONSTRAINT INDICATOR'')',IDIGIT) ! ! Declare amount of working storage allocated to FC. ! 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 FC(NDATA,XDATA,YDATA,SDDATA,NORD,NBKPT,BKPT,NCONST,XCONST, & ! ! Check coefficients. ! YCONST,NDERIV,MODE,COEFF,W,IW) TOL = 7.0E0*SQRT(R1MACH(4)) DIFF = 0.0E0 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 SVOUT (NDATA,COEFCK, & '(/'' PREDICTED COEFFICIENTS OF THE B-SPLINE '// & 'FROM SAMPLE'')',IDIGIT) call SVOUT (NDATA,COEFF, & '(/'' COEFFICIENTS OF THE B-SPLINE COMPUTED '// & 'BY FC'')',IDIGIT) ! ! Compute value, first two derivatives and probable uncertainty. ! end if N = NBKPT - NORD NVAL = 51 ! ! The function BVALU is in the de Boor B-spline package. ! DO 70 I = 1,NVAL XVAL = REAL(I-1)/(NVAL-1) II = 1 DO 60 J = 1,3 V(I,J+1) = BVALU(BKPT,COEFF,N,NORD,J-1,XVAL,II,WORK) 60 continue ! ! The variance function CV is a companion subprogram to FC. ! V(I,1) = XVAL V(I,5) = SQRT(CV(XVAL,NDATA,NCONST,NORD,NBKPT,BKPT,W)) ! 70 continue DIFF = 0.0E0 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 SMOUT(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 FC(NDATA,XDATA,YDATA,SDDATA,0,NBKPT,BKPT,NCONST,XCONST, & YCONST,NDERIV,MODE,COEFF,W,IW) if ( NUMXER(NERR) /= 2) FATAL = .TRUE. ! call xerclr call FC(NDATA,XDATA,YDATA,SDDATA,NORD,0,BKPT,NCONST,XCONST, & YCONST,NDERIV,MODE,COEFF,W,IW) if ( NUMXER(NERR) /= 2) FATAL = .TRUE. ! call xerclr call FC(-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 FC(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 FC(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 FC(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 FC') 9010 FORMAT (/ ' FC PASSED TEST 1') 9020 FORMAT (/ ' FC FAILED TEST 1') 9030 FORMAT (/ ' FC (AND BVALU) PASSED TEST 2') 9040 FORMAT (/ ' FC (AND BVALU) 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 (/' *****************FC PASSED ALL TESTS*****************') 9110 FORMAT (/' ****************FC FAILED SOME TESTS*****************') end !! FDEQC !***SUBSIDIARY !***PURPOSE Derivative evaluator for DEPAC quick checks. !***LIBRARY SLATEC !***TYPE SINGLE 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 F to FDEQC. (WRB) !***END PROLOGUE FDEQC ! ! Declare arguments. ! subroutine FDEQC (T, U, UPRIME, RPAR, IPAR) integer IPAR(*) ! ! Declare local variables. ! REAL RPAR(*), T, U(*), UPRIME(*) !***FIRST EXECUTABLE STATEMENT FDEQC REAL 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 !! FDTRUE !***SUBSIDIARY !***PURPOSE Compute exact function values for EVCHCK. !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE 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 FDTRUE subroutine FDTRUE (X, F, D) REAL X, F, D ! !***FIRST EXECUTABLE STATEMENT FDTRUE 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 FDTRUE FOLLOWS ----------------------------- return END REAL FUNCTION FEIN (T) !! FEIN !***PURPOSE Subsidiary to EG8CK. !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***COMMON BLOCKS FEINX !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE FEIN COMMON /FEINX/ X, A, FKM !***FIRST EXECUTABLE STATEMENT FEIN REAL X, A, FKM, T, ALN ALN = (FKM-T)*X - A*LOG(T) FEIN = EXP(ALN) return END subroutine fftqx ( LUN, KPRINT, ipass ) ! !! FFTQX is a quick check for the NCAR FFT routines. ! !***PURPOSE Quick check for the NCAR FFT routines. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Swarztrauber, P. N., (NCAR) !***DESCRIPTION ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! VERSION 4 APRIL 1985 ! ! A TEST DRIVER FOR ! A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE FAST FOURIER ! TRANSFORM OF PERIODIC AND OTHER SYMMETRIC SEQUENCES ! ! BY ! ! PAUL N SWARZTRAUBER ! ! NATIONAL CENTER FOR ATMOSPHERIC RESEARCH BOULDER, COLORADO 80307 ! ! WHICH IS SPONSORED BY THE NATIONAL SCIENCE FOUNDATION ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! THIS PROGRAM TESTS THE PACKAGE OF FAST FOURIER ! TRANSFORMS FOR BOTH COMPLEX AND REAL PERIODIC SEQUENCES AND ! CERTAIN OTHER SYMMETRIC SEQUENCES THAT ARE LISTED BELOW. ! ! 1. RFFTI INITIALIZE RFFTF AND RFFTB ! 2. RFFTF FORWARD TRANSFORM OF A REAL PERIODIC SEQUENCE ! 3. RFFTB BACKWARD TRANSFORM OF A REAL COEFFICIENT ARRAY ! ! 4. EZFFTI INITIALIZE EZFFTF AND EZFFTB ! 5. EZFFTF A SIMPLIFIED REAL PERIODIC FORWARD TRANSFORM ! 6. EZFFTB A SIMPLIFIED REAL PERIODIC BACKWARD TRANSFORM ! ! 7. SINTI INITIALIZE SINT ! 8. SINT SINE TRANSFORM OF A REAL ODD SEQUENCE ! ! 9. COSTI INITIALIZE COST ! 10. COST COSINE TRANSFORM OF A REAL EVEN SEQUENCE ! ! 11. SINQI INITIALIZE SINQF AND SINQB ! 12. SINQF FORWARD SINE TRANSFORM WITH ODD WAVE NUMBERS ! 13. SINQB UNNORMALIZED INVERSE OF SINQF ! ! 14. COSQI INITIALIZE COSQF AND COSQB ! 15. COSQF FORWARD COSINE TRANSFORM WITH ODD WAVE NUMBERS ! 16. COSQB UNNORMALIZED INVERSE OF COSQF ! ! 17. CFFTI INITIALIZE CFFTF AND CFFTB ! 18. CFFTF FORWARD TRANSFORM OF A COMPLEX PERIODIC SEQUENCE ! 19. CFFTB UNNORMALIZED INVERSE OF CFFTF ! !***ROUTINES CALLED CFFTB, CFFTF, CFFTI, COSQB, COSQF, COSQI, COST, ! COSTI, EZFFTB, EZFFTF, EZFFTI, PIMACH, R1MACH, ! RFFTB, RFFTF, RFFTI, SINQB, SINQF, SINQI, SINT, ! SINTI !***REVISION HISTORY (YYMMDD) ! 790601 DATE WRITTEN ! 890718 Changed computation of PI to use PIMACH. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901205 Changed usage of R1MACH(3) to R1MACH(4). (RWC) ! 910708 Minor modifications in use of KPRINT. (WRB) ! 920211 Code cleaned up, an error in printing an error message fixed ! and comments on PASS/FAIL of individual tests added. (WRB) ! 920618 Code upgraded to "Version 4". (BKS, WRB) ! 930315 Modified RFFT* tests to compute "slow-transform" in DOUBLE ! PRECISION. (WRB) !***END PROLOGUE FFTQX ! real a(100) real ah(100) double precision ARG double precision ARG1 double precision ARG2 REAL AZERO REAL AZEROH real b(100) real bh(100) real cf real cosqbt real cosqfb real cosqft real costfb real costt COMPLEX CX(200) COMPLEX CY(200) real dcfb real dcfftb real dcfftf real dezb1 real dezf1 real dezfb double precision DT real errmax integer i integer IPASS integer j integer k integer KPRINT integer LUN integer modn integer n integer, dimension ( 10 ) :: ND = (/ 120, 54, 49, 32, 4, 3, 2, 0, 0, 0 /) integer nm1 integer nns integer np1 integer ns2 integer ns2m integer nz double precision PI REAL R1MACH real rftb real rftf real rftfb real sign real sinqbt real sinqfb real sinqft real sintfb real sintt real sqrt2 double precision SUM double precision SUM1 double precision SUM2 real tpi real w(2000) real x(200) real xh(200) real y(200) ! SQRT2 = SQRT(2.0) ERRMAX = 2.0*SQRT(R1MACH(4)) NNS = 7 PI = 4.0D0*ATAN(1.0D0) if ( kprint >= 2) then write (LUN, 9000) end if ipass = 1 DO NZ = 1, NNS N = ND(NZ) if ( kprint >= 2) write (LUN, 9010) N MODN = MOD(N, 2) NP1 = N + 1 NM1 = N - 1 DO J=1,NP1 X(J) = SIN(J*SQRT2) Y(J) = X(J) XH(J) = X(J) end do ! ! Test RFFTI, RFFTF and RFFTB ! call RFFTI(N, W) DT = (PI+PI)/N NS2 = (N+1)/2 DO K=2,NS2 SUM1 = 0.0D0 SUM2 = 0.0D0 ARG = (K-1)*DT DO I=1,N ARG1 = (I-1)*ARG SUM1 = SUM1 + X(I)*COS(ARG1) SUM2 = SUM2 + X(I)*SIN(ARG1) end do Y(2*K-2) = SUM1 Y(2*K-1) = -SUM2 end do SUM1 = 0.0D0 SUM2 = 0.0D0 DO I=1,NM1,2 SUM1 = SUM1 + X(I) SUM2 = SUM2 + X(I+1) end do if ( MODN == 1) then SUM1 = SUM1 + X(N) end if Y(1) = SUM1 + SUM2 if ( MODN == 0) then Y(N) = SUM1 - SUM2 end if call RFFTF(N, X, W) RFTF = 0.0 DO I=1,N RFTF = max ( RFTF, ABS(X(I)-Y(I))) X(I) = XH(I) end do RFTF = RFTF/N if ( RFTF <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9020) else ipass = 0 if ( kprint >= 2) write (LUN, 9030) end if SIGN = 1.0 DO I=1,N SUM = 0.5D0*X(1) ARG = (I-1)*DT DO K=2,NS2 ARG1 = (K-1)*ARG SUM = SUM + X(2*K-2)*COS(ARG1) - X(2*K-1)*SIN(ARG1) end do if ( MODN == 0) SUM = SUM + 0.5D0*SIGN*X(N) Y(I) = SUM + SUM SIGN = -SIGN end do call RFFTB(N, X, W) RFTB = 0.0 DO I=1,N RFTB = max ( RFTB, ABS(X(I)-Y(I))) X(I) = XH(I) Y(I) = XH(I) end do RFTB = RFTB/N if ( RFTB <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9040) else ipass = 0 if ( kprint >= 2) write (LUN, 9050) end if call RFFTB(N, Y, W) call RFFTF(N, Y, W) CF = 1.0/N RFTFB = 0.0 DO I=1,N RFTFB = max ( RFTFB, ABS(CF*Y(I)-X(I))) end do if ( RFTFB <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9060) else ipass = 0 if ( kprint >= 2) write (LUN, 9070) end if ! ! Test SINTI and SINT ! DT = PI/N DO I=1,NM1 X(I) = XH(I) end do DO I=1,NM1 Y(I) = 0.0 ARG1 = I*DT DO K=1,NM1 Y(I) = Y(I) + X(K)*SIN((K)*ARG1) end do Y(I) = Y(I) + Y(I) end do call SINTI(NM1, W) call SINT(NM1, X, W) CF = 0.5 / N SINTT = 0.0 DO I = 1, NM1 SINTT = max ( SINTT, ABS(X(I)-Y(I))) X(I) = XH(I) Y(I) = X(I) end do SINTT = CF*SINTT if ( SINTT <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9080) else ipass = 0 if ( kprint >= 2) write (LUN, 9090) end if call SINT(NM1, X, W) call SINT(NM1, X, W) SINTFB = 0.0 DO I=1,NM1 SINTFB = max ( SINTFB, ABS(CF*X(I)-Y(I))) end do if ( SINTFB <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9100) else ipass = 0 if ( kprint >= 2) write (LUN, 9110) end if ! ! Test COSTI and COST ! DO I=1,NP1 X(I) = XH(I) end do SIGN = 1.0 DO I=1,NP1 Y(I) = 0.5*(X(1)+SIGN*X(N+1)) ARG = (I-1)*DT DO K=2,N Y(I) = Y(I) + X(K)*COS((K-1)*ARG) end do Y(I) = Y(I) + Y(I) SIGN = -SIGN end do call COSTI(NP1, W) call COST(NP1, X, W) COSTT = 0.0 DO I=1,NP1 COSTT = max ( COSTT, ABS(X(I)-Y(I))) X(I) = XH(I) Y(I) = XH(I) end do COSTT = CF*COSTT if ( COSTT <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9120) else ipass = 0 if ( kprint >= 2) write (LUN, 9130) end if call COST(NP1, X, W) call COST(NP1, X, W) COSTFB = 0.0 DO I=1,NP1 COSTFB = max ( COSTFB, ABS(CF*X(I)-Y(I))) end do if ( COSTFB <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9140) else ipass = 0 if ( kprint >= 2) write (LUN, 9150) end if ! ! Test SINQI, SINQF and SINQB ! CF = 0.25/N DO I=1,N Y(I) = XH(I) end do DT = PI/(N+N) DO I=1,N X(I) = 0.0 ARG = I*DT DO K=1,N X(I) = X(I) + Y(K)*SIN((K+K-1)*ARG) end do X(I) = 4.0*X(I) end do call SINQI(N, W) call SINQB(N, Y, W) SINQBT = 0.0 DO I=1,N SINQBT = max ( SINQBT, ABS(Y(I)-X(I))) X(I) = XH(I) end do SINQBT = CF*SINQBT if ( SINQBT <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9160) else ipass = 0 if ( kprint >= 2) write (LUN, 9170) end if SIGN = 1.0 DO I=1,N ARG = (I+I-1)*DT Y(I) = 0.5*SIGN*X(N) DO K=1,NM1 Y(I) = Y(I) + X(K)*SIN((K)*ARG) end do Y(I) = Y(I) + Y(I) SIGN = -SIGN end do call SINQF(N, X, W) SINQFT = 0.0 DO I=1,N SINQFT = max ( SINQFT, ABS(X(I)-Y(I))) Y(I) = XH(I) X(I) = XH(I) end do if ( SINQFT <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9180) else ipass = 0 if ( kprint >= 2) write (LUN, 9190) end if call SINQF(N, Y, W) call SINQB(N, Y, W) SINQFB = 0.0 DO I=1,N SINQFB = max ( SINQFB, ABS(CF*Y(I)-X(I))) end do if ( SINQFB <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9200) else ipass = 0 if ( kprint >= 2) write (LUN, 9210) end if ! ! Test COSQI, COSQF and COSQB ! DO I=1,N Y(I) = XH(I) end do DO I=1,N X(I) = 0.0 ARG = (I-1)*DT DO K=1,N X(I) = X(I) + Y(K)*COS((K+K-1)*ARG) end do X(I) = 4.0*X(I) end do call COSQI(N, W) call COSQB(N, Y, W) COSQBT = 0.0 DO I=1,N COSQBT = max ( COSQBT, ABS(X(I)-Y(I))) X(I) = XH(I) end do COSQBT = CF*COSQBT if ( COSQBT <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9220) else ipass = 0 if ( kprint >= 2) write (LUN, 9230) end if DO I=1,N Y(I) = 0.5*X(1) ARG = (I+I-1)*DT DO K=2,N Y(I) = Y(I) + X(K)*COS((K-1)*ARG) end do Y(I) = Y(I) + Y(I) end do call COSQF(N, X, W) COSQFT = 0.0 DO I=1,N COSQFT = max ( COSQFT, ABS(Y(I)-X(I))) X(I) = XH(I) Y(I) = XH(I) end do COSQFT = CF*COSQFT if ( COSQFT <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9240) else ipass = 0 if ( kprint >= 2) write (LUN, 9250) end if call COSQB(N, X, W) call COSQF(N, X, W) COSQFB = 0.0 DO I=1,N COSQFB = max ( COSQFB, ABS(CF*X(I)-Y(I))) end do if ( COSQFB <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9260) else ipass = 0 if ( kprint >= 2) write (LUN, 9270) end if ! ! Test EZFFTI, EZFFTF and EZFFTB ! call EZFFTI(N, W) DO I=1,N X(I) = XH(I) end do TPI = 2.0*PI DT = TPI/N NS2 = (N+1)/2 CF = 2.0/N NS2M = NS2 - 1 DO K=1,NS2M SUM1 = 0.0D0 SUM2 = 0.0D0 ARG = K*DT DO I=1,N ARG1 = (I-1)*ARG SUM1 = SUM1 + X(I)*COS(ARG1) SUM2 = SUM2 + X(I)*SIN(ARG1) end do A(K) = CF*SUM1 B(K) = CF*SUM2 end do NM1 = N - 1 SUM1 = 0.0D0 SUM2 = 0.0D0 DO I=1,NM1,2 SUM1 = SUM1 + X(I) SUM2 = SUM2 + X(I+1) end do if ( MODN == 1) then SUM1 = SUM1 + X(N) end if AZERO = 0.5*CF*(SUM1+SUM2) if ( MODN == 0) then A(NS2) = 0.5*CF*(SUM1-SUM2) end if call EZFFTF(N, X, AZEROH, AH, BH, W) DEZF1 = ABS(AZEROH-AZERO) if ( MODN == 0) then DEZF1 = max ( DEZF1, ABS(A(NS2)-AH(NS2))) end if DO I=1,NS2M DEZF1 = max ( DEZF1, ABS(AH(I)-A(I)), ABS(BH(I)-B(I))) end do if ( DEZF1 <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9280) else ipass = 0 if ( kprint >= 2) write (LUN, 9290) end if NS2 = N/2 if ( MODN == 0) B(NS2) = 0.0 DO I=1,N SUM = AZERO ARG1 = (I-1)*DT DO K=1,NS2 ARG2 = K*ARG1 SUM = SUM + A(K)*COS(ARG2) + B(K)*SIN(ARG2) end do X(I) = SUM end do call EZFFTB(N, Y, AZERO, A, B, W) DEZB1 = 0.0 DO I=1,N DEZB1 = max ( DEZB1, ABS(X(I)-Y(I))) X(I) = XH(I) end do if ( DEZB1 <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9300) else ipass = 0 if ( kprint >= 2) write (LUN, 9310) end if call EZFFTF(N, X, AZERO, A, B, W) call EZFFTB(N, Y, AZERO, A, B, W) DEZFB = 0.0 DO I=1,N DEZFB = max ( DEZFB, ABS(X(I)-Y(I))) end do if ( DEZFB <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9320) else ipass = 0 if ( kprint >= 2) write (LUN, 9330) end if ! ! Test CFFTI, CFFTF and CFFTB ! DO I=1,N CX(I) = CMPLX(COS(SQRT2*I), SIN(SQRT2*(I*I))) end do DT = (PI+PI)/N DO I=1,N ARG1 = -(I-1)*DT CY(I) = (0.0,0.0) DO K=1,N ARG2 = (K-1)*ARG1 CY(I) = CY(I) + CMPLX(COS(ARG2),SIN(ARG2))*CX(K) end do end do call CFFTI(N, W) call CFFTF(N, CX, W) DCFFTF = 0.0 DO I=1,N DCFFTF = max ( DCFFTF, CABS(CX(I)-CY(I))) CX(I) = CX(I)/N end do DCFFTF = DCFFTF/N if ( DCFFTF <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9340) else ipass = 0 if ( kprint >= 2) write (LUN, 9350) end if DO I=1,N ARG1 = (I-1)*DT CY(I) = (0.0,0.0) DO K=1,N ARG2 = (K-1)*ARG1 CY(I) = CY(I) + CMPLX(COS(ARG2),SIN(ARG2))*CX(K) end do end do call CFFTB(N, CX, W) DCFFTB = 0.0 DO I=1,N DCFFTB = max ( DCFFTB, CABS(CX(I)-CY(I))) CX(I) = CY(I) end do if ( DCFFTB <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9360) else ipass = 0 if ( kprint >= 2) write (LUN, 9370) end if CF = 1.0/N call CFFTF(N, CX, W) call CFFTB(N, CX, W) DCFB = 0.0 DO I = 1, N DCFB = max ( DCFB, CABS(CF*CX(I)-CY(I))) end do if ( DCFB <= ERRMAX ) then if ( kprint >= 3) write (LUN, 9380) else ipass = 0 if ( kprint >= 2) write (LUN, 9390) end if if ( kprint >= 3 ) then write (LUN, 9400) N, RFTF, RFTB, RFTFB, SINTT, SINTFB, & COSTT, COSTFB, SINQFT, SINQBT, SINQFB, COSQFT, COSQBT, & COSQFB, DEZF1, DEZB1, DEZFB, DCFFTF, DCFFTB, DCFB end if end do if ( KPRINT >= 2 .and. ipass == 1) then write (LUN, 9410) end if if ( KPRINT >= 1 .and. ipass == 0) then write (LUN, 9420) end if return 9000 FORMAT ('1' / ' FFT QUICK CHECK') 9010 FORMAT (/ ' Test FFT routines with a sequence of length ', I3) 9020 FORMAT (' Test of RFFTF PASSED') 9030 FORMAT (' Test of RFFTF FAILED') 9040 FORMAT (' Test of RFFTB PASSED') 9050 FORMAT (' Test of RFFTB FAILED') 9060 FORMAT (' Test of RFFTF and RFFTB PASSED') 9070 FORMAT (' Test of RFFTF and RFFTB FAILED') 9080 FORMAT (' First test of SINT PASSED') 9090 FORMAT (' First test of SINT FAILED') 9100 FORMAT (' Second test of SINT PASSED') 9110 FORMAT (' Second test of SINT FAILED') 9120 FORMAT (' First test of COST PASSED') 9130 FORMAT (' First test of COST FAILED') 9140 FORMAT (' Second test of COST PASSED') 9150 FORMAT (' Second test of COST FAILED') 9160 FORMAT (' Test of SINQB PASSED') 9170 FORMAT (' Test of SINQB FAILED') 9180 FORMAT (' Test of SINQF PASSED') 9190 FORMAT (' Test of SINQF FAILED') 9200 FORMAT (' Test of SINQF and SINQB PASSED') 9210 FORMAT (' Test of SINQF and SINQB FAILED') 9220 FORMAT (' Test of COSQB PASSED') 9230 FORMAT (' Test of COSQB FAILED') 9240 FORMAT (' Test of COSQF PASSED') 9250 FORMAT (' Test of COSQF FAILED') 9260 FORMAT (' Test of COSQF and COSQB PASSED') 9270 FORMAT (' Test of COSQF and COSQB FAILED') 9280 FORMAT (' Test of EZFFTF PASSED') 9290 FORMAT (' Test of EZFFTF FAILED') 9300 FORMAT (' Test of EZFFTB PASSED') 9310 FORMAT (' Test of EZFFTB FAILED') 9320 FORMAT (' Test of EZFFTF and EZFFTB PASSED') 9330 FORMAT (' Test of EZFFTF and EZFFTB FAILED') 9340 FORMAT (' Test of CFFTF PASSED') 9350 FORMAT (' Test of CFFTF FAILED') 9360 FORMAT (' Test of CFFTB PASSED') 9370 FORMAT (' Test of CFFTB FAILED') 9380 FORMAT (' Test of CFFTF and CFFTB PASSED') 9390 FORMAT (' Test of CFFTF and CFFTB FAILED') 9400 FORMAT ('0N', I5, ' RFFTF ', E9.3, ' RFFTB ', E9.3, & ' RFFTFB ',E9.3 / & 7X, ' SINT ', E9.3, ' SINTFB ', E9.3 / & 7X, ' COST ', E9.3 , ' COSTFB ' , E9.3 / & 7X, ' SINQF ', E9.3, ' SINQB ', E9.3, ' SINQFB ', & E9.3 / & 7X, ' COSQF ', E9.3, ' COSQB ', E9.3, ' COSQFB ', & E9.3 / & 7X, ' DEZF1 ', E9.3, ' DEZB1 ', E9.3, ' DEZFB ', & E9.3 / & 7X, ' CFFTF ', E9.3, ' CFFTB ', E9.3, ' CFFTFB ', & E9.3) 9410 FORMAT (/ ' ***********FFT ROUTINES PASSED ALL TESTS************') 9420 FORMAT (/ ' ***********FFT ROUTINES FAILED SOME TESTS***********') end !! FMAT !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***COMMON BLOCKS SAVEX !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE FMAT subroutine FMAT (X, Y, YP) dimension Y(*),YP(*) !***FIRST EXECUTABLE STATEMENT FMAT COMMON /SAVEX/ XSAVE, TERM YP(1) = Y(2) if ( X == XSAVE) GO TO 10 XSAVE=X TANX=TAN(X/57.2957795130823) TERM=3.0/TANX+2.0*TANX 10 YP(2) = -TERM*Y(2)-0.7*Y(1) return end !! FQD1 !***SUBSIDIARY !***PURPOSE Function evaluator for QNC79 and GAUS8 quick checks. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (FQD1-S, DFQD1-D) !***AUTHOR Boland, W. Robert, (LANL) !***SEE ALSO QG8TST, QN79QX !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 920229 DATE WRITTEN !***END PROLOGUE FQD1 ! .. Scalar Arguments .. REAL FUNCTION FQD1 (X) ! .. Intrinsic Functions .. REAL X !***FIRST EXECUTABLE STATEMENT FQD1 INTRINSIC SQRT FQD1 = 0.0E0 if ( X > 0.0E0 ) then FQD1 = 1.0E0/SQRT(X) end if return end !! FQD2 !***SUBSIDIARY !***PURPOSE Function evaluator for QNC79 and GAUS8 quick checks. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (FQD2-S, DFQD2-D) !***AUTHOR Boland, W. Robert, (LANL) !***SEE ALSO QG8TST, QN79QX !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 920229 DATE WRITTEN !***END PROLOGUE FQD2 ! .. Scalar Arguments .. REAL FUNCTION FQD2 (X) ! .. Intrinsic Functions .. REAL X !***FIRST EXECUTABLE STATEMENT FQD2 INTRINSIC COS, EXP FQD2 = EXP(X)*COS(10.0E0*X) return end !! FZTEST !***PURPOSE Quick check for FZERO. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (FZTEST-S, DFZTST-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED FZERO, 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) ! 910501 Added PURPOSE and TYPE records. (WRB) ! 910708 Minor modifications in use of KPRINT. (WRB) ! 920212 Code completely restructured to test IFLAG for all values ! of KPRINT. (WRB) !***END PROLOGUE FZTEST ! .. Scalar Arguments .. subroutine FZTEST (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN integer IFLAG, KONTRL REAL AE, B, C, PI, R, RE, TOL ! .. External Functions .. LOGICAL FATAL REAL R1MACH ! .. External Subroutines .. EXTERNAL R1MACH ! .. Intrinsic Functions .. EXTERNAL FZERO, XERCLR, XGETF, XSETF !***FIRST EXECUTABLE STATEMENT FZTEST INTRINSIC ABS, ATAN, MAX, SIN, SQRT, TAN if ( kprint >= 2) write (LUN,9000) ipass = 1 PI = 4.0E0 *ATAN(1.0E0) RE = 1.0E-6 AE = 1.0E-6 ! ! Set up and solve example problem ! TOL = max ( 1.0E-5,SQRT(R1MACH(4))) B = 0.1E0 C = 4.0E0 R = C - B ! ! See if test was passed. ! call FZERO (SIN, 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.0E0 C = 2.0E0 R = 0.5E0*(B+C) call FZERO (TAN, 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.0E0 C = -0.1E0 R = 0.5E0*(B+C) call FZERO (SIN, 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' / ' FZERO 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 (/' ***************FZERO PASSED ALL TESTS**************') 9070 FORMAT (/' ***************FZERO FAILED SOME TESTS*************') end !! GVEC !***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 GVEC subroutine GVEC (X, G) !***FIRST EXECUTABLE STATEMENT GVEC dimension G(*) G(1) = 0.0 G(2) = 1.0+COS(X) return end !! HEADER !***PURPOSE Print header for BLAS quick checks. !***LIBRARY SLATEC !***AUTHOR Lawson, C. L., (JPL) !***ROUTINES CALLED (NONE) !***COMMON BLOCKS COMBLA !***REVISION HISTORY (YYMMDD) ! 741212 DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920210 Minor modifications to prologue and code. (WRB) !***END PROLOGUE HEADER subroutine HEADER (KPRINT) COMMON /COMBLA/ NPRINT, ICASE, N, INCX, INCY, MODE, PASS LOGICAL PASS ! CHARACTER*6 L(38) DATA L(1) /' SDOT'/ DATA L(2) /' DSDOT'/ DATA L(3) /'SDSDOT'/ DATA L(4) /' DDOT'/ DATA L(5) /'DQDOTI'/ DATA L(6) /'DQDOTA'/ DATA L(7) /' CDOTC'/ DATA L(8) /' CDOTU'/ DATA L(9) /' SAXPY'/ DATA L(10) /' DAXPY'/ DATA L(11) /' CAXPY'/ DATA L(12) /' SROTG'/ DATA L(13) /' DROTG'/ DATA L(14) /' SROT'/ DATA L(15) /' DROT'/ DATA L(16) /'SROTMG'/ DATA L(17) /'DROTMG'/ DATA L(18) /' SROTM'/ DATA L(19) /' DROTM'/ DATA L(20) /' SCOPY'/ DATA L(21) /' DCOPY'/ DATA L(22) /' CCOPY'/ DATA L(23) /' SSWAP'/ DATA L(24) /' DSWAP'/ DATA L(25) /' CSWAP'/ DATA L(26) /' SNRM2'/ DATA L(27) /' DNRM2'/ DATA L(28) /'SCNRM2'/ DATA L(29) /' SASUM'/ DATA L(30) /' DASUM'/ DATA L(31) /'SCASUM'/ DATA L(32) /' SSCAL'/ DATA L(33) /' DSCAL'/ DATA L(34) /' CSCAL'/ DATA L(35) /'CSSCAL'/ DATA L(36) /'ISAMAX'/ DATA L(37) /'IDAMAX'/ !***FIRST EXECUTABLE STATEMENT HEADER DATA L(38) /'ICAMAX'/ if ( kprint >= 2) write (NPRINT,9000) ICASE,L(ICASE) ! return 9000 FORMAT (' Test of subprogram number', I3, 2X, A) end !! HSRTQC !***SUBSIDIARY !***PURPOSE Quick check for SLATEC routine HPSORT, HPPERM !***LIBRARY SLATEC !***CATEGORY N6A !***TYPE CHARACTER (SSRTQC-S, DSRTQC-D, ISRTQC-I, HSRTQC-H) !***KEYWORDS HPPERM, HPSORT, QUICK CHECK !***AUTHOR Boisvert, Ronald, (NIST) !***REFERENCES (NONE) !***ROUTINES CALLED HPPERM, HPSORT !***REVISION HISTORY (YYMMDD) ! 890620 DATE WRITTEN ! 901005 Included test of HPPERM. (MAM) ! 920511 Added error message tests. (MAM) !***END PROLOGUE HSRTQC ! subroutine HSRTQC (LUN, KPRINT, IPASS) integer N, NTEST ! PARAMETER (N=9,NTEST=4) LOGICAL FAIL CHARACTER*1 SHORT CHARACTER*2 X(N,NTEST), XS(N,NTEST), Y(N), WORK(N) integer IX(N,NTEST), IY(N), KFLAG(NTEST), KPRINT, LUN, IPASS, J, & ! ! --------- ! TEST DATA ! --------- ! ! X = TEST VECTOR ! XS = TEST VECTOR IN SORTED ORDER ! IX = PERMUTATION VECTOR, I.E. X(IX(J)) = XS(J) ! I, KABS, IER, NERR, NUMXER, NN, KKFLAG, STRBEG, STREND DATA KFLAG(1) / 2 / DATA (X(I,1),I=1,N) /'AC','AZ','AD','AA','AB','ZZ','ZA','ZX','ZY'/ DATA (IX(I,1),I=1,N)/ 4, 5, 1, 3, 2, 7, 8, 9, 6/ ! DATA (XS(I,1),I=1,N)/'AA','AB','AC','AD','AZ','ZA','ZX','ZY','ZZ'/ DATA KFLAG(2) / -1 / DATA (X(I,2),I=1,N) /'AA','BB','CC','DD','EE','FF','GG','HH','II'/ DATA (IX(I,2),I=1,N)/ 9, 8, 7, 6, 5, 4, 3, 2, 1 / ! DATA (XS(I,2),I=1,N)/'II','HH','GG','FF','EE','DD','CC','BB','AA'/ DATA KFLAG(3) / -2 / DATA (X(I,3),I=1,N) /'AA','BB','CC','DD','EE','FF','GG','HH','II'/ DATA (IX(I,3),I=1,N)/ 9, 8, 7, 6, 5, 4, 3, 2, 1/ ! DATA (XS(I,3),I=1,N)/'II','HH','GG','FF','EE','DD','CC','BB','AA'/ DATA KFLAG(4) / 1 / DATA (X(I,4),I=1,N) /'AC','AZ','AD','AA','AB','ZZ','ZA','ZX','ZY'/ DATA (IX(I,4),I=1,N)/ 4, 5, 1, 3, 2, 7, 8, 9, 6/ ! !***FIRST EXECUTABLE STATEMENT HSRTQC DATA (XS(I,4),I=1,N)/'AA','AB','AC','AD','AZ','ZA','ZX','ZY','ZZ'/ if ( kprint >= 2 ) then write (LUN,2001) '=================' write (LUN,2002) 'OUTPUT FROM HSRTQC' write (LUN,2002) '=================' end if ! ! ------------------------------------------------------------- ! CHECK HPSORT ! ------------------------------------------------------------- ! ipass = 1 ! ! ... SETUP PROBLEM ! DO 300 J=1,NTEST DO 210 I=1,N Y(I) = X(I,J) ! ! ... call ROUTINE TO BE TESTED ! 210 continue ! ! ... EVALUATE RESULTS ! call HPSORT(Y,N,1,2,IY,KFLAG(J),WORK,IER) KABS = ABS(KFLAG(J)) FAIL = .FALSE. .OR. (IER > 0) DO 220 I=1,N FAIL = FAIL .OR. (IY(I) /= IX(I,J)) & .OR. ((KABS == 1) .and. (Y(I) /= X(I,J))) & .OR. ((KABS == 2) .and. (Y(I) /= XS(I,J))) ! ! ... PRODUCE REQUIRED OUTPUT ! 220 continue if ( FAIL ) then ipass = 0 if ( kprint > 0) WRITE(LUN,2001) 'HPSORT FAILED TEST ',J else if ( kprint >= 2) WRITE(LUN,2001) 'HPSORT PASSED TEST ',J end if if ( (FAIL .and. (KPRINT >= 2)) .OR. (KPRINT >= 3) ) then write (LUN,2001) '-------------------------' write (LUN,2002) 'DETAILS OF HPSORT TEST ',J write (LUN,2002) '-------------------------' write (LUN,2002) '1ST ARGUMENT (VECTOR TO BE SORTED)' write (LUN,2003) ' INPUT = ',(X(I,J),I=1,N) write (LUN,2003) ' COMPUTED OUTPUT = ',(Y(I),I=1,N) if ( KABS == 1 ) then write (LUN,2003) ' CORRECT OUTPUT = ',(X(I,J),I=1,N) else write (LUN,2003) ' CORRECT OUTPUT = ',(XS(I,J),I=1,N) end if write (LUN,2002) '2ND ARGUMENT (VECTOR LENGTH)' write (LUN,2004) ' INPUT = ',N write (LUN,2002) '3RD ARGUMENT (PERMUTATION VECTOR)' write (LUN,2004) ' COMPUTED OUTPUT = ',(IY(I),I=1,N) write (LUN,2004) ' CORRECT OUTPUT = ',(IX(I,J),I=1,N) write (LUN,2002) '4TH ARGUMENT (TYPE OF SORT)' write (LUN,2004) ' INPUT = ',KFLAG(J) ! end if ! ! ... TEST ERROR MESSAGES ! 300 continue if ( kprint <= 2 ) then call xsetf ( 0 ) else call xsetf ( -1 ) ! end if NN=-1 STRBEG=1 STREND=2 KKFLAG=1 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call HPSORT(Y,NN,STRBEG,STREND,IY,KKFLAG,WORK,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 NN=1 STRBEG=1 STREND=2 KKFLAG=0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call HPSORT(Y,NN,STRBEG,STREND,IY,KKFLAG,WORK,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 NN=1 STRBEG=1 STREND=2 KKFLAG=1 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call HPSORT(Y,NN,STRBEG,STREND,IY,KKFLAG,SHORT,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 NN=1 STRBEG=2 STREND=1 KKFLAG=1 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call HPSORT(Y,NN,STRBEG,STREND,IY,KKFLAG,WORK,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 NN=1 STRBEG=-1 STREND=2 KKFLAG=1 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call HPSORT(Y,NN,STRBEG,STREND,IY,KKFLAG,WORK,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 NN=1 STRBEG=1 STREND=3 KKFLAG=1 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call HPSORT(Y,NN,STRBEG,STREND,IY,KKFLAG,WORK,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 if ( (KPRINT >= 2) .and. (IPASS == 1) ) then write (LUN,*) write (LUN,*)' HPSORT PASSED ERROR MESSAGE TESTS' else if ( (KPRINT >= 1) .and. (IPASS == 0) ) then write (LUN,*) write (LUN,*)' HPSORT FAILED ERROR MESSAGE TESTS' ! ! ------------------------------------------------------------- ! CHECK HPPERM ! ------------------------------------------------------------- ! end if ! ! ... SETUP PROBLEM ! DO 400 J=1,NTEST KABS = ABS(KFLAG(J)) DO 310 I=1,N Y(I) = X(I,J) if ( KABS == 1 ) then IY(I) = I else IY(I) = IX(I,J) end if ! ! ... call ROUTINE TO BE TESTED ! 310 continue ! ! ... EVALUATE RESULTS ! call HPPERM(Y,N,IY,WORK,IER) FAIL = .FALSE. .OR. (IER > 0) DO 320 I=1,N FAIL = FAIL .OR. ((KABS == 1) .and. (IY(I) /= I)) & .OR. ((KABS == 2) .and. (IY(I) /= IX(I,J))) & .OR. ((KABS == 1) .and. (Y(I) /= X(I,J))) & .OR. ((KABS == 2) .and. (Y(I) /= XS(I,J))) ! ! ... PRODUCE REQUIRED OUTPUT ! 320 continue if ( FAIL ) then ipass = 0 if ( kprint > 0) WRITE(LUN,2001)'HPPERM FAILED TEST ',J else if ( KPRINT >= 2) WRITE(LUN,2001)'HPPERM PASSED TEST ',J end if if ( (FAIL .and. (KPRINT >= 2)) .OR. (KPRINT>=3) ) then write (LUN,2001)'------------------------' write (LUN,2002)'DETAILS OF HPPERM TEST',J write (LUN,2002)'------------------------' write (LUN,2002)'1ST ARGUMENT (VECTOR TO BE PERMUTED)' write (LUN,2003)' INPUT =',(X(I,J),I=1,N) write (LUN,2003)' COMPUTED OUTPUT =',(Y(I),I=1,N) if ( KABS == 1 ) then write (LUN,2003)' CORRECT OUTPUT =',(X(I,J),I=1,N) else write (LUN,2003)' CORRECT OUTPUT =',(XS(I,J),I=1,N) end if write (LUN,2002)'2ND ARGUMENT (VECTOR LENGTH)' write (LUN,2004)' INPUT =',N write (LUN,2002)'3RD ARGUMENT (PERMUTATION VECTOR)' write (LUN,2004)' INPUT =',(IY(I),I=1,N) write (LUN,2002)'4TH ARGUMENT (ERROR FLAG)' write (LUN,2004)' OUTPUT =',IER ! end if ! ! ... TEST ERROR MESSAGES ! 400 continue if ( kprint <= 2 ) then call xsetf ( 0 ) else call xsetf ( -1 ) ! end if NN=-1 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call HPPERM(Y,NN,IY,WORK,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 NN=1 IY(1)=5 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call HPPERM(Y,NN,IY,WORK,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 if ( (KPRINT >= 2) .and. (IPASS == 1) ) then write (LUN,*) write (LUN,*)' HPPERM PASSED ERROR MESSAGE TESTS' else if ( (KPRINT >= 1) .and. (IPASS == 0) ) then write (LUN,*) write (LUN,*)' HPPERM FAILED ERROR MESSAGE TESTS' ! end if ! return 2001 FORMAT(/ 1X,A,I2) 2002 FORMAT(1X,A,I2) 2003 FORMAT(1X,A,9(2X,A2)) 2004 FORMAT(1X,A,9I4) end !! ISMPL !***SUBSIDIARY !***PURPOSE Generate integer sample. ! This routine picks M "random" integers in the range 1 to ! N without any repetitions. !***LIBRARY SLATEC (SLAP) !***TYPE INTEGER (ISMPL-I) !***AUTHOR Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-300 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***ROUTINES CALLED RAND !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890919 Changed to integer name ISMPL. (MKS) ! 890920 Converted prologue to SLATEC 4.0 format. (FNF) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE ISMPL ! .. Scalar Arguments .. subroutine ISMPL (N, M, INDX) ! .. Array Arguments .. integer M, N ! .. Local Scalars .. integer INDX(M) REAL DUMMY ! .. External Functions .. integer I, ID, J REAL RAND ! .. Intrinsic Functions .. EXTERNAL RAND !***FIRST EXECUTABLE STATEMENT ISMPL ! ! Check the input ! INTRINSIC INT DUMMY = 0.0 ! ! Set the indices. if ( N*M < 0 .OR. M > N ) RETURN !VD$ NOCONCUR INDX(1) = INT( RAND(DUMMY)*N ) + 1 DO 30 I = 2, M ! ! Check to see if ID has already been chosen. !VD$ NOVECTOR !VD$ NOCONCUR 10 ID = INT( RAND(DUMMY)*N ) + 1 DO 20 J = 1, I-1 if ( ID == INDX(J) ) GOTO 10 20 continue INDX(I) = ID 30 continue ! -------- LAST LINE OF ISMPL FOLLOWS ------------------------------ return end !! ISRTQC !***SUBSIDIARY !***PURPOSE Quick check for SLATEC routines ISORT, IPSORT, IPPERM !***LIBRARY SLATEC !***CATEGORY N6A !***TYPE INTEGER (SSRTQC-S, DSRTQC-D, ISRTQC-I, HSRTQC-H) !***KEYWORDS IPPERM, IPSORT, ISORT, QUICK CHECK !***AUTHOR Boisvert, Ronald, (NIST) !***REFERENCES (NONE) !***ROUTINES CALLED IPPERM, IPSORT, ISORT !***REVISION HISTORY (YYMMDD) ! 890620 DATE WRITTEN ! 901005 Included test of IPPERM. (MAM) ! 920511 Added error message tests. (MAM) !***END PROLOGUE ISRTQC ! subroutine ISRTQC (LUN, KPRINT, IPASS) integer N, NTEST ! PARAMETER (N=9,NTEST=4) LOGICAL FAIL integer X(N,NTEST), XS(N,NTEST), Y(N), YC(N) integer IX(N,NTEST), IY(N), KFLAG(NTEST), KPRINT, LUN, IPASS, J, & ! ! --------- ! TEST DATA ! --------- ! ! X = TEST VECTOR ! XS = TEST VECTOR IN SORTED ORDER ! IX = PERMUTATION VECTOR, I.E. X(IX(J)) = XS(J) ! I, KABS, IER, NERR, NUMXER, NN, KKFLAG DATA KFLAG(1) / 2 / DATA (X(I,1),I=1,N) / 36, 54, -1, 29, 1, 80, 98, 99, 55/ DATA (IX(I,1),I=1,N)/ 3, 5, 4, 1, 2, 9, 6, 7, 8/ ! DATA (XS(I,1),I=1,N)/ -1, 1, 29, 36, 54, 55, 80, 98, 99/ DATA KFLAG(2) / -1 / DATA (X(I,2),I=1,N) / 1, 2, 3, 4, 5, 6, 7, 8, 9/ DATA (IX(I,2),I=1,N)/ 9, 8, 7, 6, 5, 4, 3, 2, 1/ ! DATA (XS(I,2),I=1,N)/ 9, 8, 7, 6, 5, 4, 3, 2, 1/ DATA KFLAG(3) / -2 / DATA (X(I,3),I=1,N) / -9, -8, -7, -6, -5, -4, -3, -2, -1/ DATA (IX(I,3),I=1,N)/ 9, 8, 7, 6, 5, 4, 3, 2, 1/ ! DATA (XS(I,3),I=1,N)/ -1, -2, -3, -4, -5, -6, -7, -8, -9/ DATA KFLAG(4) / 1 / DATA (X(I,4),I=1,N) / 36, 54, -1, 29, 1, 80, 98, 99, 55/ DATA (IX(I,4),I=1,N)/ 3, 5, 4, 1, 2, 9, 6, 7, 8/ ! !***FIRST EXECUTABLE STATEMENT ISRTQC DATA (XS(I,4),I=1,N)/ -1, 1, 29, 36, 54, 55, 80, 98, 99/ if ( kprint >= 2 ) then write (LUN,2001) '=================' write (LUN,2002) 'OUTPUT FROM ISRTQC' write (LUN,2002) '=================' end if ! ! ------------------------------------------------------------- ! CHECK ISORT ! ------------------------------------------------------------- ! ipass = 1 ! ! ... SETUP PROBLEM ! DO 200 J=1,NTEST DO 110 I=1,N Y(I) = X(I,J) YC(I) = X(I,J) ! ! ... call ROUTINE TO BE TESTED ! 110 continue ! ! ... EVALUATE RESULTS ! call ISORT(Y,YC,N,KFLAG(J)) KABS = ABS(KFLAG(J)) FAIL = .FALSE. DO 120 I=1,N FAIL = FAIL .OR. (Y(I) /= XS(I,J)) & .OR. ((KABS == 1) .and. (YC(I) /= X(I,J))) & .OR. ((KABS == 2) .and. (YC(I) /= XS(I,J))) ! ! ... PRODUCE REQUIRED OUTPUT ! 120 continue if ( FAIL ) then ipass = 0 if ( kprint > 0) WRITE(LUN,2001) 'ISORT FAILED TEST ',J else if ( kprint >= 2) WRITE(LUN,2001) 'ISORT PASSED TEST ',J end if if ( (FAIL .and. (KPRINT >= 2)) .OR. (KPRINT >= 3) ) then write (LUN,2001) '------------------------' write (LUN,2002) 'DETAILS OF ISORT TEST ',J write (LUN,2002) '------------------------' write (LUN,2002) '1ST ARGUMENT (VECTOR TO BE SORTED)' write (LUN,2003) ' INPUT = ',(X(I,J),I=1,N) write (LUN,2003) ' COMPUTED OUTPUT = ',(Y(I),I=1,N) write (LUN,2003) ' CORRECT OUTPUT = ',(XS(I,J),I=1,N) write (LUN,2002) '2ND ARGUMENT (VECTOR CARRIED ALONG)' write (LUN,2003) ' INPUT = ',(X(I,J),I=1,N) write (LUN,2003) ' COMPUTED OUTPUT = ',(YC(I),I=1,N) if ( KABS == 1 ) then write (LUN,2003) ' CORRECT OUTPUT = ',(X(I,J),I=1,N) else write (LUN,2003) ' CORRECT OUTPUT = ',(XS(I,J),I=1,N) end if write (LUN,2002) '3RD ARGUMENT (VECTOR LENGTH)' write (LUN,2004) ' INPUT = ',N write (LUN,2002) '4TH ARGUMENT (TYPE OF SORT)' write (LUN,2004) ' INPUT = ',KFLAG(J) end if ! ! ------------------------------------------------------------- ! CHECK IPSORT ! ------------------------------------------------------------- ! 200 continue ! ! ... SETUP PROBLEM ! DO 300 J=1,NTEST DO 210 I=1,N Y(I) = X(I,J) ! ! ... call ROUTINE TO BE TESTED ! 210 continue ! ! ... EVALUATE RESULTS ! call IPSORT(Y,N,IY,KFLAG(J),IER) KABS = ABS(KFLAG(J)) FAIL = .FALSE. .OR. (IER > 0) DO 220 I=1,N FAIL = FAIL .OR. (IY(I) /= IX(I,J)) & .OR. ((KABS == 1) .and. (Y(I) /= X(I,J))) & .OR. ((KABS == 2) .and. (Y(I) /= XS(I,J))) ! ! ... PRODUCE REQUIRED OUTPUT ! 220 continue if ( FAIL ) then ipass = 0 if ( kprint > 0) WRITE(LUN,2001) 'IPSORT FAILED TEST ',J else if ( kprint >= 2) WRITE(LUN,2001) 'IPSORT PASSED TEST ',J end if if ( (FAIL .and. (KPRINT >= 2)) .OR. (KPRINT >= 3) ) then write (LUN,2001) '-------------------------' write (LUN,2002) 'DETAILS OF IPSORT TEST ',J write (LUN,2002) '-------------------------' write (LUN,2002) '1ST ARGUMENT (VECTOR TO BE SORTED)' write (LUN,2003) ' INPUT = ',(X(I,J),I=1,N) write (LUN,2003) ' COMPUTED OUTPUT = ',(Y(I),I=1,N) if ( KABS == 1 ) then write (LUN,2003) ' CORRECT OUTPUT = ',(X(I,J),I=1,N) else write (LUN,2003) ' CORRECT OUTPUT = ',(XS(I,J),I=1,N) end if write (LUN,2002) '2ND ARGUMENT (VECTOR LENGTH)' write (LUN,2004) ' INPUT = ',N write (LUN,2002) '3RD ARGUMENT (PERMUTATION VECTOR)' write (LUN,2004) ' COMPUTED OUTPUT = ',(IY(I),I=1,N) write (LUN,2004) ' CORRECT OUTPUT = ',(IX(I,J),I=1,N) write (LUN,2002) '4TH ARGUMENT (TYPE OF SORT)' write (LUN,2004) ' INPUT = ',KFLAG(J) ! end if ! ! ... TEST ERROR MESSAGES ! 300 continue if ( kprint <= 2 ) then call xsetf ( 0 ) else call xsetf ( -1 ) ! end if NN=-1 KKFLAG=1 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call IPSORT(Y,NN,IY,KKFLAG,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 NN=1 KKFLAG=0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call IPSORT(Y,NN,IY,KKFLAG,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 if ( (KPRINT >= 2) .and. (IPASS == 1) ) then write (LUN,*) write (LUN,*)' IPSORT PASSED ERROR MESSAGE TESTS' else if ( (KPRINT >= 1) .and. (IPASS == 0) ) then write (LUN,*) write (LUN,*)' IPSORT FAILED ERROR MESSAGE TESTS' ! ! ------------------------------------------------------------- ! CHECK IPPERM ! ------------------------------------------------------------- ! end if ! ! ... SETUP PROBLEM ! DO 400 J=1,NTEST KABS = ABS(KFLAG(J)) DO 310 I=1,N Y(I) = X(I,J) if ( KABS == 1 ) then IY(I) = I else IY(I) = IX(I,J) end if ! ! ... call ROUTINE TO BE TESTED ! 310 continue ! ! ... EVALUATE RESULTS ! call IPPERM(Y,N,IY,IER) FAIL = .FALSE. .OR. (IER > 0) DO 320 I=1,N FAIL = FAIL .OR. ((KABS == 1) .and. (IY(I) /= I)) & .OR. ((KABS == 2) .and. (IY(I) /= IX(I,J))) & .OR. ((KABS == 1) .and. (Y(I) /= X(I,J))) & .OR. ((KABS == 2) .and. (Y(I) /= XS(I,J))) ! ! ... PRODUCE REQUIRED OUTPUT ! 320 continue if ( FAIL ) then ipass = 0 if ( kprint > 0) WRITE(LUN,2001)'IPPERM FAILED TEST ',J else if ( KPRINT >= 2) WRITE(LUN,2001)'IPPERM PASSED TEST ',J end if if ( (FAIL .and. (KPRINT >= 2)) .OR. (KPRINT>=3) ) then write (LUN,2001)'------------------------' write (LUN,2002)'DETAILS OF IPPERM TEST',J write (LUN,2002)'------------------------' write (LUN,2002)'1ST ARGUMENT (VECTOR TO BE PERMUTED)' write (LUN,2003)' INPUT =',(X(I,J),I=1,N) write (LUN,2003)' COMPUTED OUTPUT =',(Y(I),I=1,N) if ( KABS == 1 ) then write (LUN,2003)' CORRECT OUTPUT =',(X(I,J),I=1,N) else write (LUN,2003)' CORRECT OUTPUT =',(XS(I,J),I=1,N) end if write (LUN,2002)'2ND ARGUMENT (VECTOR LENGTH)' write (LUN,2004)' INPUT =',N write (LUN,2002)'3RD ARGUMENT (PERMUTATION VECTOR)' write (LUN,2004)' INPUT =',(IY(I),I=1,N) write (LUN,2002)'4TH ARGUMENT (ERROR FLAG)' write (LUN,2004)' OUTPUT =',IER ! end if ! ! ... TEST ERROR MESSAGES ! 400 continue if ( kprint <= 2 ) then call xsetf ( 0 ) else call xsetf ( -1 ) ! end if NN=-1 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call IPPERM(Y,NN,IY,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 NN=1 IY(1)=5 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call IPPERM(Y,NN,IY,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 if ( (KPRINT >= 2) .and. (IPASS == 1) ) then write (LUN,*) write (LUN,*)' IPPERM PASSED ERROR MESSAGE TESTS' else if ( (KPRINT >= 1) .and. (IPASS == 0) ) then write (LUN,*) write (LUN,*)' IPPERM FAILED ERROR MESSAGE TESTS' ! end if ! return 2001 FORMAT(/ 1X,A,I2) 2002 FORMAT(1X,A,I2) 2003 FORMAT(1X,A,9I4) 2004 FORMAT(1X,A,9I4) end !! ITEST !***PURPOSE Compare arrays ICOMP and ITRUE. !***LIBRARY SLATEC !***TYPE INTEGER (ITEST-I) !***KEYWORDS QUICK CHECK !***AUTHOR Lawson, C. L., (JPL) !***DESCRIPTION ! ! This subroutine compares the arrays ICOMP and ITRUE of length LEN ! for equality. In the case of an unequal compare, appropriate ! messages are written. ! !***ROUTINES CALLED (NONE) !***COMMON BLOCKS COMBLA !***REVISION HISTORY (YYMMDD) ! 741210 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920211 Code restructured and information added to the DESCRIPTION ! section. (WRB) !***END PROLOGUE ITEST subroutine ITEST (LEN, ICOMP, ITRUE, KPRINT) integer ICOMP(*), ITRUE(*) LOGICAL PASS !***FIRST EXECUTABLE STATEMENT ITEST COMMON /COMBLA/ NPRINT, ICASE, N, INCX, INCY, MODE, PASS DO 100 I = 1,LEN ! ! Here ICOMP(I) is not equal to ITRUE(I). ! if ( ICOMP(I) /= ITRUE(I) ) then ! ! Print FAIL message and header. ! if ( PASS ) then PASS = .FALSE. if ( kprint >= 3 ) then write (NPRINT,9000) write (NPRINT,9010) end if end if if ( kprint >= 3 ) then ID = ICOMP(I) - ITRUE(I) write (NPRINT,9020) ICASE, N, INCX, INCY, MODE, I, ICOMP(I), & ITRUE(I), ID end if end if 100 continue return 9000 FORMAT ('+', 39X, 'FAIL') 9010 FORMAT ('0CASE N INCX INCY MODE I', 29X, 'COMP(I)', 29X, & 'TRUE(I)', 2X, 'DIFFERENCE' / 1X) 9020 FORMAT (1X, I4, I3, 3I5, I3, 2I36, I12) end !! JAC !***SUBSIDIARY !***PURPOSE Evaluate Jacobian for DEBDF quick check. !***LIBRARY SLATEC !***TYPE SINGLE 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. (WRB) !***END PROLOGUE JAC subroutine JAC (T, U, PD, NROWPD, RPAR, IPAR) integer IPAR, NROWPD REAL PD, R, R5, RPAR, RSQ, T, U, U1SQ, U2SQ, U1U2 !***FIRST EXECUTABLE STATEMENT JAC 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.E0*U1SQ - RSQ)/R5 PD(4,1) = 3.E0*U1U2/R5 PD(3,2) = PD(4,1) PD(4,2) = (3.E0*U2SQ - RSQ)/R5 PD(1,3) = 1.E0 PD(2,4) = 1.E0 return end !! LCE !***SUBSIDIARY !***PURPOSE Test if two arrays are identical. !***LIBRARY SLATEC (BLAS) !***AUTHOR Du Croz, J. J., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! Tests if two arrays are identical. ! ! 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 LCE ! .. Scalar Arguments .. LOGICAL FUNCTION LCE (RI, RJ, LR) ! .. Array Arguments .. integer LR ! .. Local Scalars .. COMPLEX RI( * ), RJ( * ) !***FIRST EXECUTABLE STATEMENT LCE integer I LCE = .TRUE. DO 10 I = 1, LR if ( RI( I ) /= RJ( I ) ) then LCE = .FALSE. GO TO 30 end if 10 continue ! ! End of LCE. ! 30 RETURN end !! LCERES !***SUBSIDIARY !***PURPOSE Test if selected elements in two arrays are equal. !***LIBRARY SLATEC (BLAS) !***AUTHOR Du Croz, J. J., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! Tests if selected elements in two arrays are equal. ! ! TYPE is 'GE', 'HE' or 'HP'. ! ! 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 LCERES ! .. Scalar Arguments .. LOGICAL FUNCTION LCERES (TYPE, UPLO, M, N, AA, AS, LDA) integer LDA, M, N CHARACTER*1 UPLO ! .. Array Arguments .. CHARACTER*2 TYPE ! .. Local Scalars .. COMPLEX AA( LDA, * ), AS( LDA, * ) integer I, IBEG, IEND, J !***FIRST EXECUTABLE STATEMENT LCERES LOGICAL UPPER UPPER = UPLO == 'U' if ( TYPE == 'GE' ) then DO 20 J = 1, N DO 10 I = M + 1, LDA if ( AA( I, J ) /= AS( I, J ) ) & GO TO 70 10 continue 20 continue else if ( TYPE == 'HE' ) then DO 50 J = 1, N if ( UPPER ) then IBEG = 1 IEND = J else IBEG = J IEND = N end if DO 30 I = 1, IBEG - 1 if ( AA( I, J ) /= AS( I, J ) ) & GO TO 70 30 continue DO 40 I = IEND + 1, LDA if ( AA( I, J ) /= AS( I, J ) ) & GO TO 70 40 continue 50 continue ! end if LCERES = .TRUE. GO TO 80 70 continue LCERES = .FALSE. ! ! End of LCERES. ! 80 RETURN end !! LDE !***SUBSIDIARY !***PURPOSE Test if two arrays are identical. !***LIBRARY SLATEC (BLAS) !***AUTHOR Du Croz, J. J., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! Tests if two arrays are identical. ! ! 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 LDE ! .. Scalar Arguments .. LOGICAL FUNCTION LDE (RI, RJ, LR) ! .. Array Arguments .. integer LR ! .. Local Scalars .. double precision RI( * ), RJ( * ) !***FIRST EXECUTABLE STATEMENT LDE integer I LDE = .TRUE. DO 10 I = 1, LR if ( RI( I ) /= RJ( I ) ) then LDE = .FALSE. GO TO 30 end if 10 continue ! ! End of LDE. ! 30 RETURN end !! LDERES !***SUBSIDIARY !***PURPOSE Test if selected elements in two arrays are equal. !***LIBRARY SLATEC (BLAS) !***AUTHOR Du Croz, J. J., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! Tests if selected elements in two arrays are equal. ! ! TYPE is 'GE', 'SY' or 'SP'. ! ! 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 LDERES ! .. Scalar Arguments .. LOGICAL FUNCTION LDERES (TYPE, UPLO, M, N, AA, AS, LDA) integer LDA, M, N CHARACTER*1 UPLO ! .. Array Arguments .. CHARACTER*2 TYPE ! .. Local Scalars .. double precision AA( LDA, * ), AS( LDA, * ) integer I, IBEG, IEND, J !***FIRST EXECUTABLE STATEMENT LDERES LOGICAL UPPER UPPER = UPLO == 'U' if ( TYPE == 'GE' ) then DO 20 J = 1, N DO 10 I = M + 1, LDA if ( AA( I, J ) /= AS( I, J ) ) & GO TO 70 10 continue 20 continue else if ( TYPE == 'SY' ) then DO 50 J = 1, N if ( UPPER ) then IBEG = 1 IEND = J else IBEG = J IEND = N end if DO 30 I = 1, IBEG - 1 if ( AA( I, J ) /= AS( I, J ) ) & GO TO 70 30 continue DO 40 I = IEND + 1, LDA if ( AA( I, J ) /= AS( I, J ) ) & GO TO 70 40 continue 50 continue ! end if LDERES = .TRUE. GO TO 80 70 continue LDERES = .FALSE. ! ! End of LDERES. ! 80 RETURN end !! LSE !***SUBSIDIARY !***PURPOSE Test if two arrays are identical. !***LIBRARY SLATEC (BLAS) !***AUTHOR Du Croz, J. J., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! Tests if two arrays are identical. ! ! 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 LSE ! .. Scalar Arguments .. LOGICAL FUNCTION LSE (RI, RJ, LR) ! .. Array Arguments .. integer LR ! .. Local Scalars .. REAL RI( * ), RJ( * ) !***FIRST EXECUTABLE STATEMENT LSE integer I LSE = .TRUE. DO 10 I = 1, LR if ( RI( I ) /= RJ( I ) ) then LSE = .FALSE. GO TO 30 end if 10 continue ! ! End of LSE. ! 30 RETURN end !! LSEIQX !***PURPOSE Quick check for LSEI. !***LIBRARY SLATEC !***TYPE SINGLE 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 LSEI, R1MACH, SAXPY, SCOPY, SDOT, SNRM2, SVOUT !***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 R1MACH(4) rather than R1MACH(3) and cleaned up ! FORMATs. (RWC) ! 920722 Initialized IP(1) and IP(2) for call to LSEI. (BKS, WRB) ! 930214 Declarations sections added, code revised to test error ! returns for all values of kprint and code polished. (WRB) !***END PROLOGUE LSEIQX ! .. Scalar Arguments .. subroutine LSEIQX (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN REAL 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 REAL 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) REAL R1MACH, SDOT, SNRM2 integer NUMXER ! .. External Subroutines .. EXTERNAL NUMXER, R1MACH, SDOT, SNRM2 ! .. Intrinsic Functions .. EXTERNAL LSEI, SAXPY, SCOPY, SVOUT, 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 LSEIQX /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 SCOPY(MG, G(1,I), 1, D(MEAP1,I), 1) call SCOPY(MA, A(1,I), 1, D(MEP1,I), 1) ! ! Copy the right-side vectors into the work array in compatible ! order. ! 10 continue call SCOPY(MG, H, 1, D(MEAP1,NP1), 1) ! ! Use default program options in LSEI, and set matrix-vector ! printing accuracy parameters. ! call SCOPY(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 20 I = 1, MA WORK(I) = SDOT(N,D(I,1),MDD,SOL,1) - F(I) 20 continue ! ! Call LSEI to get solution in X(*), least squares residual in ! RNORML. ! RESNRM = SNRM2(MA,WORK,1) call LSEI(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 = SNRM2(N,SOL,1) call SCOPY(N, SOL, 1, ERR, 1) call SAXPY(N, -1.0E0, X, 1, ERR, 1) CNORM = SNRM2(N, ERR, 1) RELERR = CNORM/TNORM ! RELNRM = (RESNRM-RNORML)/RESNRM if ( RELERR <= 70.0E0*SQRT(R1MACH(4)) .and. & RELNRM <= 5.0E0*R1MACH(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 SVOUT(N, ERR, & '('' RESIDUALS FROM KNOWN LEAST SQUARES SOLUTION'')', & IDIGIT) call SVOUT(N, X, '(/'' SOLUTION COMPUTED BY LSEI'')', JDIGIT) ! end if if ( kprint >= 2 ) then ! ! Print out the known and computed residual norms. ! if ( .NOT.(KPRINT == 2 .and. ipass /= 0) ) then call SVOUT(1, RESNRM, & '(/'' RESIDUAL NORM OF KNOWN LEAST SQUARES SOLUTION'')', & JDIGIT) call SVOUT(1, RNORML, & ! ! Print out the computed solution relative error. ! '(/'' RESIDUAL NORM COMPUTED BY LSEI'')', JDIGIT) call SVOUT(1, RELERR, & ! ! Print out the computed relative error in residual norm. ! '(/'' COMPUTED SOLUTION RELATIVE ERROR'')', IDIGIT) call SVOUT(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 LSEI (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 LSEI (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 LSEI') 9010 FORMAT (/' LSEI PASSED TEST') 9020 FORMAT (/' LSEI FAILED TEST'/' RELERR = ',1P,E20.6/' RELNRM = ', & E20.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 (/' ****************LSEI PASSED ALL TESTS***************') 9110 FORMAT (/' ****************LSEI FAILED SOME TESTS**************') end !! LSERES !***SUBSIDIARY !***PURPOSE Test if selected elements in two arrays are equal. !***LIBRARY SLATEC (BLAS) !***AUTHOR Du Croz, J. J., (NAG) ! Hanson, R. J., (SNLA) !***DESCRIPTION ! ! Tests if selected elements in two arrays are equal. ! ! TYPE is 'GE', 'SY' or 'SP'. ! ! 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 LSERES ! .. Scalar Arguments .. LOGICAL FUNCTION LSERES (TYPE, UPLO, M, N, AA, AS, LDA) integer LDA, M, N CHARACTER*1 UPLO ! .. Array Arguments .. CHARACTER*2 TYPE ! .. Local Scalars .. REAL AA( LDA, * ), AS( LDA, * ) integer I, IBEG, IEND, J !***FIRST EXECUTABLE STATEMENT LSERES LOGICAL UPPER UPPER = UPLO == 'U' if ( TYPE == 'GE' ) then DO 20 J = 1, N DO 10 I = M + 1, LDA if ( AA( I, J ) /= AS( I, J ) ) & GO TO 70 10 continue 20 continue else if ( TYPE == 'SY' ) then DO 50 J = 1, N if ( UPPER ) then IBEG = 1 IEND = J else IBEG = J IEND = N end if DO 30 I = 1, IBEG - 1 if ( AA( I, J ) /= AS( I, J ) ) & GO TO 70 30 continue DO 40 I = IEND + 1, LDA if ( AA( I, J ) /= AS( I, J ) ) & GO TO 70 40 continue 50 continue ! end if continue LSERES = .TRUE. GO TO 80 70 continue LSERES = .FALSE. ! ! End of LSERES. ! 80 RETURN end !! OUTERR !***SUBSIDIARY !***PURPOSE Output error messages for the SLAP Quick Check. !***LIBRARY SLATEC (SLAP) !***TYPE SINGLE PRECISION (OUTERR-S, DUTERR-D) !***AUTHOR Seager, Mark K., (LLNL) ! Lawrence Livermore National Laboratory ! PO BOX 808, L-300 ! Livermore, CA 94550 (510) 423-3141 ! seager@llnl.gov !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 881010 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890920 Converted prologue to SLATEC 4.0 format. (FNF) ! 920511 Added complete declaration section. (WRB) ! 921021 Added 1P's to output formats. (FNF) !***END PROLOGUE OUTERR ! .. Scalar Arguments .. subroutine OUTERR (METHOD, IERR, IOUT, nfail, ISTDO, ITER, ERR) REAL ERR integer IERR, IOUT, ISTDO, ITER, nfail !***FIRST EXECUTABLE STATEMENT OUTERR CHARACTER METHOD*6 if ( IERR /= 0 ) nfail = nfail + 1 if ( IOUT == 1 .and. IERR /= 0 ) then write (ISTDO,1000) METHOD end if if ( IOUT == 2 ) then if ( IERR == 0 ) then write (ISTDO,1010) METHOD else write (ISTDO,1020) METHOD,IERR,ITER,ERR end if end if if ( IOUT >= 3 ) then if ( IERR == 0 ) then write (ISTDO,1030) METHOD,IERR,ITER,ERR else write (ISTDO,1020) METHOD,IERR,ITER,ERR end if end if return 1000 FORMAT( 1X,A6,' : **** FAILURE ****') 1010 FORMAT( 1X,A6,' : **** PASSED ****') 1020 FORMAT(' **************** WARNING ***********************'/ & ' **** ',A6,' Quick Test FAILED: IERR = ',I5,' ****'/ & ' **************** WARNING ***********************'/ & ' Iteration Count = ',I3,' Stop Test = ',1P,E12.6) 1030 FORMAT(' ***************** PASSED ***********************'/ & ' **** ',A6,' Quick Test PASSED: IERR = ',I5,' ****'/ & ' ***************** PASSED ***********************'/ & ! -------- LAST LINE OF OUTERR FOLLOWS ---------------------------- ' Iteration Count = ',I3,' Stop Test = ',1P,E12.6) end !! PASS !***PURPOSE Print a PASS/FAIL message for a particular quick check ! test. !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920210 PURPOSE added and code restructured. (WRB) !***END PROLOGUE PASS subroutine PASS (LUN, ICNT, ITEST) !***FIRST EXECUTABLE STATEMENT PASS integer ICNT, ITEST, LUN if ( ITEST /= 0 ) then write (LUN,9000) ICNT else write (LUN,9100) ICNT end if return 9000 FORMAT(/ ' TEST NUMBER', I5, ' PASSED') 9100 FORMAT(/ ' *****TEST NUMBER' ,I5, ' FAILED**********') end !! PCHQK1 !***PURPOSE Test the PCHIP evaluators CHFDV, CHFEV, PCHFD and PCHFE. !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE PRECISION (PCHQK1-S, DPCHQ1-D) !***KEYWORDS PCHIP EVALUATOR QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! PCHIP QUICK CHECK NUMBER 1 ! ! TESTS THE EVALUATORS: CHFDV, CHFEV, PCHFD, PCHFE. ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call PCHQK1 (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: ! EVCHCK tests the single-cubic evaluators. ! EVPCCK tests the full PCH evaluators. ! EVERCK exercises the error returns in all evaluators. ! !***ROUTINES CALLED EVCHCK, EVERCK, EVPCCK !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890306 Changed ipass to the more accurate name IFAIL. (FNF) ! 890618 REVISION DATE from Version 3.2 ! 890706 Cosmetic changes to prologue. (WRB) ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900309 Added EVERCK 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 PCHQK1 ! ! Declare arguments. ! subroutine PCHQK1 (LUN, KPRINT, IPASS) ! ! DECLARE LOCAL VARIABLES. ! integer LUN, KPRINT, IPASS integer I1, I2, I3, I4, I5, I6, I7, I8, I9, IFAIL, NPTS REAL WORK (4000) ! !***FIRST EXECUTABLE STATEMENT PCHQK1 LOGICAL FAIL ! ! TEST CHFDV AND CHFEV. ! if ( kprint >= 2) write (LUN, 1000) KPRINT IFAIL = 0 NPTS = 1000 I1 = 1 + NPTS I2 = I1 + NPTS I3 = I2 + NPTS call EVCHCK (LUN, KPRINT, NPTS, WORK(1), WORK(I1), WORK(I2), & WORK(I3), FAIL) ! ! TEST PCHFD AND PCHFE. ! 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 EVPCCK (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 EVERCK (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 EVCHCK OUTPUT.) ! IFAIL=2 IF PCHFD/PCHFE TEST FAILED. (SEE EVPCCK OUTPUT.) ! IFAIL=4 IF ERROR RETURN TEST FAILED. (SEE EVERCK 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'/' ------------ PCHIP QUICK CHECK OUTPUT', & ' ------------' //20X,'( kprint =',I2,' )') 3001 FORMAT (/' *** TROUBLE ***',I5,' EVALUATION TESTS FAILED.') 99998 FORMAT (/' ------------ PCHIP PASSED ALL EVALUATION TESTS', & ' ------------') 99999 FORMAT (/' ************ PCHIP FAILED SOME EVALUATION TESTS', & ! -------- LAST LINE OF PCHQK1 FOLLOWS ----------------------------- ' ************') end !! PCHQK2 !***PURPOSE Test the PCHIP integrators PCHIA and PCHID. !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE PRECISION (PCHQK2-S, DPCHQ2-D) !***KEYWORDS PCHIP INTEGRATOR QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! PCHIP QUICK CHECK NUMBER 2 ! ! TESTS THE INTEGRATORS: PCHIA, PCHID. ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call PCHQK2 (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 PCHIA ! and compares the results with the correct answer. ! Since PCHIA calls PCHID, this tests both integrators. ! !***ROUTINES CALLED PCHIA, R1MACH !***REVISION HISTORY (YYMMDD) ! 820601 DATE WRITTEN ! 890306 Changed ipass to the more accurate name IFAIL. (FNF) ! 890316 Added declarations as in DPCHQ2. (FNF) ! 890629 Appended E0 to real constants to reduce S.P./D.P. ! differences. ! 890706 Cosmetic changes to prologue. (WRB) ! 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) ! 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 PCHQK2 ! ! Declare arguments. ! subroutine PCHQK2 (LUN, KPRINT, IPASS) ! ! DECLARE VARIABLES. ! integer LUN, KPRINT, IPASS integer I, IEREXP(17), IERR, IFAIL, N, NPAIRS REAL 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. ! REAL PCHIA, R1MACH REAL 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.75E0/, ONE /1.E0/, TWO /2.E0/, THREE /3.E0/ DATA N /7/ DATA X /-4.E0, -2.E0, -0.9E0, 0.E0, 0.9E0, 2.E0, 4.E0/ DATA NPAIRS /17/ DATA A /-3.0E0, 3.0E0,-0.5E0,-0.5E0,-0.5E0,-4.0E0,-4.0E0, 3.0E0, & -5.0E0,-5.0E0,-6.0E0, 6.0E0,-1.5E0,-1.5E0,-3.0E0, 3.0E0, 0.5E0/ DATA B / 3.0E0,-3.0E0, 1.0E0, 2.0E0, 5.0E0,-0.5E0, 4.0E0, 5.0E0, & -3.0E0, 5.0E0,-5.0E0, 5.0E0,-0.5E0,-1.0E0,-2.5E0, 3.5E0, 0.5E0/ ! ! SET PASS/FAIL TOLERANCE. ! !***FIRST EXECUTABLE STATEMENT PCHQK2 DATA IEREXP /0,0,0,0,2,0,0,2,1,3,3,3,0,0,0,0,0/ MACHEP = R1MACH(4) ! ! SET UP PCH FUNCTION DEFINITION. ! TOL = 100.E0*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 = PCHIA (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 PCHIP INTEGRATORS') 1001 FORMAT (//10X,'PCHQK2 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,2E20.10,E15.5,' (',I1,') *****' ) 2002 FORMAT (2F6.1,I5,1P,2E20.10,E15.5) 2003 FORMAT (/' MAXIMUM RELATIVE ERROR IS:',1P,E15.5, & ', TOLERANCE:',1P,E15.5) 3001 FORMAT (/' *** TROUBLE ***',I5,' INTEGRATION TESTS FAILED.') 99998 FORMAT (/' ------------ PCHIP PASSED ALL INTEGRATION TESTS', & ' ------------') 99999 FORMAT (/' ************ PCHIP FAILED SOME INTEGRATION TESTS', & ! -------- LAST LINE OF PCHQK2 FOLLOWS ----------------------------- ' ************') end !! PCHQK3 !***PURPOSE Test the PCHIP interpolators PCHIC, PCHIM, PCHSP. !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE PRECISION (PCHQK3-S, DPCHQ3-D) !***KEYWORDS PCHIP INTERPOLATOR QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! PCHIP QUICK CHECK NUMBER 3 ! ! TESTS THE INTERPOLATORS: PCHIC, PCHIM, PCHSP. ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call PCHQK3 (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 ! PCHIP interpolators and compares the results with those obtained ! on a Cray X/MP. Two different values of the PCHIC 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, PCHIC, PCHIM, PCHSP, R1MACH !***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. ! 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) changed. (WRB) ! 900802 Modified TOLD formula and constants in PCHIC calls to be ! compatible with DPCHQ3. (FNF) ! 901130 Several significant changes: (FNF) ! 1. Changed comparison between PCHIM and PCHIC 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 PCHQK3 ! !*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 PCHQK3 (LUN, KPRINT, IPASS) integer LUN, KPRINT, IPASS LOGICAL COMP ! ! Declare variables. ! REAL R1MACH integer I, IC(2), IERR, IFAIL, N, NBAD, NBADZ, NWK PARAMETER (N = 9, NWK = 2*N) REAL 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.0E0, MONE = -1.0E0) ! ! Initialize. ! ! Data. CHARACTER*6 RESULT DATA IC /0, 0/ DATA X /-2.2E0,-1.2E0,-1.0E0,-0.5E0,-0.01E0, 0.5E0, 1.0E0, & ! ! Results generated on Cray X/MP (9 sign. figs.) 2.0E0, 2.2E0/ DATA DM / 0. , 3.80027352E-01, 7.17253009E-01, & 5.82014161E-01, 0. ,-5.68208031E-01, & -5.13501618E-01,-7.77910977E-02,-2.45611117E-03/ DATA DC5,DC6 / 1.76950158E-02,-5.69579814E-01/ DATA DS /-5.16830792E-02, 5.71455855E-01, 7.40530225E-01, & 7.63864934E-01, 1.92614386E-02,-7.65324380E-01, & ! !***FIRST EXECUTABLE STATEMENT PCHQK3 -7.28209035E-01,-7.98445427E-02,-2.85983446E-02/ ! ! Set tolerances. IFAIL = 0 TOL = 10*R1MACH(4) TOLD = max ( 1.0E-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 PCHIM. ! end if ! -------------------------------- if ( KPRINT >= 3) write (LUN, 2000) 'IM' ! -------------------------------- ! Expect IERR=1 (one monotonicity switch). call PCHIM (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 PCHIC -- options set to reproduce PCHIM. ! end if ! -------------------------------------------------------- if ( KPRINT >= 3) write (LUN, 2000) 'IC' ! -------------------------------------------------------- ! Expect IERR=0 . call PCHIC (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 PCHIM. ! (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 PCHIC -- default nonzero switch derivatives. ! end if ! ------------------------------------------------------- if ( KPRINT >= 3) write (LUN, 2000) 'IC' ! ------------------------------------------------------- ! Expect IERR=0 . call PCHIC (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 PCHSP. ! end if ! ------------------------------------------------- if ( KPRINT >= 3) write (LUN, 2000) 'SP' ! ------------------------------------------------- ! Expect IERR=0 . call PCHSP (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 PCHIP INTERPOLATORS') 1001 FORMAT (//10X,'PCHQK3 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,E15.5,4X,E15.5,15X,E15.5) 1011 FORMAT (5X,F10.2,1P,E15.5,4X,3E15.5) 2000 FORMAT (/5X,'PCH',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,2E15.5,2X,A) 2004 FORMAT (/' **',I5,' PCHIM RESULTS FAILED TO BE EXACTLY ZERO.') 2005 FORMAT (/' **',I5,' PCH',A2,' RESULTS FAILED TOLERANCE TEST.', & ' TOL =',1P,E10.3) 2006 FORMAT (/5X,' ALL PCH',A2,' RESULTS OK.') 2007 FORMAT (/' **',I5,' PCHIC RESULTS FAILED TO AGREE WITH', & ' PREVIOUS CALL.') 3001 FORMAT (/' *** TROUBLE ***',I5,' INTERPOLATION TESTS FAILED.') 99998 FORMAT (/' ------------ PCHIP PASSED ALL INTERPOLATION TESTS', & ' ------------') 99999 FORMAT (/' ************ PCHIP FAILED SOME INTERPOLATION TESTS', & ! -------- LAST LINE OF PCHQK3 FOLLOWS ----------------------------- ' ************') end !! PCHQK4 !***PURPOSE Test the PCHIP monotonicity checker PCHCM. !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE PRECISION (PCHQK4-S, DPCHQ4-D) !***KEYWORDS PCHIP MONOTONICITY CHECKER QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! PCHIP QUICK CHECK NUMBER 4 ! ! TESTS THE MONOTONICITY CHECKER: PCHCM. ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call PCHQK4 (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 PCHMC. Finally, it reverses the data and repeats all tests. ! !***ROUTINES CALLED PCHCM !***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) ! 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 PCHQK4 ! !*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 PCHQK4 (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) REAL 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 PCHQK4 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.E0 1 continue DO 2 I = 2, MAXN, 3 D(I) = 2.E0 2 continue DO 3 I = 1, 3 F(I) = X(I) F(I+ 3) = F(I ) + 1.E0 F(I+ 6) = F(I+3) + 1.E0 F(I+ 9) = F(I+6) + 1.E0 F(I+12) = F(I+9) + 1.E0 3 continue ! Define FB, DB. F(16) = 6.E0 FB(1) = 0.E0 FB(2) = 2.E0 FB(3) = 3.E0 FB(4) = 5.E0 DB(1) = 1.E0 DB(2) = 3.E0 DB(3) = 3.E0 DB(4) = 0.E0 DO 4 I = 1, 3 FB(NB-I+1) = FB(I) DB(NB-I+1) = -DB(I) ! ! INITIALIZE. ! 4 continue ! 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 PCHCM (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 PCHCM (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 PCHIP MONOTONICITY CHECKER') 1001 FORMAT (//10X,'PCHQK4 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 (/' ------------ PCHIP PASSED ALL MONOTONICITY TESTS', & ' ------------') 99999 FORMAT (/' ************ PCHIP FAILED SOME MONOTONICITY TESTS', & ! -------- LAST LINE OF PCHQK4 FOLLOWS ----------------------------- ' ************') end !! PCHQK5 !***PURPOSE Test the PCH to B-spline conversion routine PCHBS. !***LIBRARY SLATEC (PCHIP) !***TYPE SINGLE PRECISION (PCHQK5-S, DPCHQ5-D) !***KEYWORDS PCHIP CONVERSION ROUTINE QUICK CHECK !***AUTHOR Fritsch, F. N., (LLNL) !***DESCRIPTION ! ! PCHIP QUICK CHECK NUMBER 5 ! ! TESTS THE CONVERSION ROUTINE: PCHBS. ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call PCHQK5 (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 BVALU and compares with PCH data. ! ! *Caution: ! This routine assumes BVALU has already been successfully tested. ! !***ROUTINES CALLED BVALU, PCHBS, R1MACH !***REVISION HISTORY (YYMMDD) ! 900411 DATE WRITTEN ! 900412 Corrected minor errors in initial implementation. ! 900430 Corrected errors in prologue. ! 900501 Corrected declarations. ! 930317 Improved output formats. (FNF) !***END PROLOGUE PCHQK5 ! !*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 PCHQK5 (LUN, KPRINT, IPASS) ! ! Declare externals. ! integer LUN, KPRINT, IPASS REAL BVALU, R1MACH ! ! Declare variables. ! EXTERNAL BVALU, PCHBS, R1MACH integer I, IERR, IFAIL, INBV, J, KNOTYP, K, N, NDIM, NKNOTS PARAMETER (N = 9) REAL 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.0E0) ! ! Define relative error function. ! LOGICAL FAIL REAL ANS, ERR, RELERR ! ! Define test data. ! RELERR (ERR, ANS) = ABS(ERR) / max ( 1.0E-5,ABS(ANS)) DATA X /-2.2E0, -1.2E0, -1.0E0, -0.5E0, -0.01E0, & 0.5E0, 1.0E0, 2.0E0, 2.2E0/ DATA F / 0.0079E0, 0.2369E0, 0.3679E0, 0.7788E0, 0.9999E0, & 0.7788E0, 0.3679E0, 0.1083E0, 0.0079E0/ DATA D / 0.0000E0, 0.3800E0, 0.7173E0, 0.5820E0, 0.0177E0, & ! ! Initialize. ! !***FIRST EXECUTABLE STATEMENT PCHQK5 -0.5696E0,-0.5135E0,-0.0778E0,-0.0025E0/ IFAIL = 0 TOL = 100*R1MACH(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 PCHBS (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 PCHBS. 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 = BVALU (T, BCOEF, NDIM, K, 0, X(I), INBV, WORK) FERR = F(I) - FCALC FERMAX = max ( FERMAX, RELERR(FERR,F(I)) ) DCALC = BVALU (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,'PCHQK5 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,E10.2,0P,F10.4,1P,E10.2) 2005 FORMAT (/5X,'Maximum relative errors:' & /15X,'F-error =',1P,E13.5,5X,'D-error =',E13.5 & /5X,'Both should be less than TOL =',E13.5) 2007 FORMAT (/' *** T-ARRAY MAXIMUM CHANGE =',1P,E13.5, & '; SHOULD NOT EXCEED TOLZ =',E13.5) 3001 FORMAT (/' *** TROUBLE ***',I5,' CONVERSION TESTS FAILED.') 99998 FORMAT (/' ------------ PCHIP PASSED ALL CONVERSION TESTS', & ' ------------') 99999 FORMAT (/' ************ PCHIP FAILED SOME CONVERSION TESTS', & ! -------- LAST LINE OF PCHQK5 FOLLOWS ----------------------------- ' ************') end !! PFITQX !***PURPOSE Quick check for POLFIT, PCOEF and PVALUE. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PFITQX-S, DPFITT-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED CMPARE, PASS, PCOEF, POLFIT, PVALUE, R1MACH, ! XERCLR, XGETF, XSETF !***COMMON BLOCKS CHECK !***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 R1MACH(3) to R1MACH(4) and modified the ! FORMATs. (RWC) ! 910708 Minor modifications in use of KPRINT. (WRB) ! 920214 Code restructured to test for all values of kprint and to ! provide more PASS/FAIL information. (WRB) !***END PROLOGUE PFITQX ! .. Scalar Arguments .. subroutine PFITQX (LUN, KPRINT, IPASS) ! .. Scalars in Common .. integer IPASS, KPRINT, LUN REAL EPS, RP, SVEPS, TOL ! .. Arrays in Common .. integer IERP, IERR, NORD, NORDP ! .. Local Scalars .. REAL R(11) REAL YFIT ! .. Local Arrays .. integer I, ICNT, M, MAXORD REAL A(97), TC(5), W(11), X(11), Y(11), YP(5) ! .. External Functions .. integer ITEST(9) REAL R1MACH ! .. External Subroutines .. EXTERNAL R1MACH ! .. Intrinsic Functions .. EXTERNAL CMPARE, PASS, PCOEF, POLFIT, PVALUE ! .. Common blocks .. INTRINSIC ABS, SQRT !***FIRST EXECUTABLE STATEMENT PFITQX COMMON /CHECK/ 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(R1MACH(4)) M = 11 DO 110 I = 1,M X(I) = I - 6 Y(I) = X(I)**4 ! ! Test POLFIT ! Input EPS is negative - specified level ! 110 continue W(1) = -1.0E0 EPS = -0.01E0 SVEPS = EPS MAXORD = 8 NORDP = 4 RP = 625.0E0 IERP = 1 ! ! See if test passed ! call POLFIT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) ! ! Check for suppression of printing. ! call CMPARE (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.0E0 SVEPS = EPS ! ! See if test passed ! call POLFIT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) ! ! Check for suppression of printing. ! call CMPARE (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.0E0 EPS = 0.0E0 SVEPS = EPS NORDP = 5 MAXORD = 5 ! ! See if test passed ! call POLFIT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) ! ! Check for suppression of printing. ! call CMPARE (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.0E0*R1MACH(4) SVEPS = EPS ! ! See if test passed ! call POLFIT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) ! ! Check for suppression of printing. ! call CMPARE (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 POLFIT (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.0E0 EPS = 5.0E0*R1MACH(4) SVEPS = EPS RP = 553.0E0 MAXORD = 2 IERP = 3 NORDP = 2 ! ! See if test passed ! call POLFIT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) ! ! Check for suppression of printing. ! call CMPARE (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.0E0 EPS = -0.01E0 SVEPS = EPS MAXORD = 5 ! ! See if test passed ! call POLFIT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) ! ! Check for suppression of printing. ! call CMPARE (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 PCOEF ! 240 call PASS (LUN, ICNT, ITEST(ICNT)) 250 MAXORD = 6 EPS = 0.0E0 SVEPS = EPS Y(6) = 1.0E0 DO 260 I = 1,M W(I) = 1.0E0/(Y(I)**2) 260 continue Y(6) = 0.0E0 call POLFIT (M, X, Y, W, MAXORD, NORD, EPS, R, IERR, A) ! ! See if test passed ! call PCOEF (4, 5.0E0, 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 PVALUE ! Normal call ! 270 call PASS (LUN, ICNT, ITEST(ICNT)) ! ! See if test passed ! 280 call PVALUE (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 POLFIT, PCOEF and PVALUE') 9010 FORMAT (' Exercise POLFIT') 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 (' POLFIT 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 PCOEF') 9140 FORMAT (/ ' For C=1.0, correct coefficient = ', E15.8, & ' computed = ', E15.8) 9150 FORMAT (/ ' Exercise PVALUE') 9160 FORMAT (' Normal execution') 9170 FORMAT (' For X = ', F5.2, ' correct P(X) = ', E15.8, & ' P(X) from PVALUE = ', E15.8) 9180 FORMAT (/' ***************POLFIT PASSED ALL TESTS***************') 9190 FORMAT (/' ***************POLFIT FAILED SOME TESTS**************') end !! PNTCHK !***PURPOSE Quick check for POLINT, POLCOF and POLYVL !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (PNTCHK-S, DPNTCK-D) !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***ROUTINES CALLED NUMXER, POLCOF, POLINT, POLYVL, 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) ! 910708 Minor modifications in use of KPRINT. (WRB) ! 920212 Code completely restructured to test errors for all values ! of KPRINT. (WRB) !***END PROLOGUE PNTCHK ! .. Scalar Arguments .. subroutine PNTCHK (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN REAL TOL, YF integer I, IERR, KONTRL, N, NERR ! .. Local Arrays .. LOGICAL FATAL ! .. External Functions .. REAL C(6), D(6), DCHK(6), W(12), X(6), XCHK(6), Y(6) REAL R1MACH integer NUMXER ! .. External Subroutines .. EXTERNAL R1MACH, NUMXER ! .. Intrinsic Functions .. EXTERNAL POLCOF, POLINT, POLYVL, XERCLR, XGETF, XSETF ! .. Data statements .. INTRINSIC ABS, SQRT DATA X / 1.0E0, 2.0E0, 3.0E0, -1.0E0, -2.0E0, -3.0E0 / DATA Y / 0.0E0, 9.0E0, 64.0E0, 0.0E0, 9.0E0, 64.0E0 / DATA XCHK / 1.0E0, 0.0E0, -2.0E0, 0.0E0, 1.0E0, 0.0E0 / !***FIRST EXECUTABLE STATEMENT PNTCHK DATA DCHK / 1.0E0, 0.0E0, -4.0E0, 0.0E0, 24.0E0, 0.0E0 / ! ! Initialize variables for tests. ! if ( kprint >= 2) write (LUN,9000) TOL = SQRT(R1MACH(4)) ipass = 1 ! ! Set up polynomial test. ! N = 6 call POLINT (N, X, Y, C) ! ! Check to see if POLCOF test passed. ! call POLCOF (0.0E0, N, X, C, D, W) FATAL = .FALSE. DO 110 I = 1,N if ( ABS(D(I)-XCHK(I)) > TOL ) then ipass = 0 FATAL = .TRUE. end if 110 continue 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) ! ! Test POLYVL. ! end if call POLYVL (5, 0.0E0, 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 120 I = 1,5 if ( ABS(DCHK(I+1)-D(I)) > TOL ) then ipass = 0 FATAL = .TRUE. end if ! ! Trigger 2 error conditions ! 120 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,9030) call POLINT (0, X, Y, C) if ( NUMXER(NERR) /= 2 ) then ipass = 0 FATAL = .TRUE. end if call xerclr X(1) = -1.0E0 call POLINT (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 POLINT, POLCOF and POLYVL') 9010 FORMAT (/ 'POLCOF ', 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 POLCOF are' / 1X, 6F10.3 /) 9020 FORMAT (' Derivative test ', A / & ' The derivatives of the polynomial at zero as ', & 'computed by POLYVL 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 (/' ****************POLINT PASSED ALL TESTS**************') 9090 FORMAT (/' ***************POLINT FAILED SOME TESTS**************') end subroutine QC36J (LUN, KPRINT, IPASS) !*****************************************************************************80 ! !! QC36J !***SUBSIDIARY !***PURPOSE THIS IS A QUICK CHECK PROGRAM FOR THE SUBROUTINES RC3JJ, ! RC3JM, AND RC6J, WHICH CALCULATE THE WIGNER COEFFICIENTS, ! 3J AND 6J. !***LIBRARY SLATEC !***CATEGORY C19 !***TYPE SINGLE 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 NUMXER, R1MACH, RC3JJ, RC3JM, RC6J, 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 RACAH. These changes were ! made by M. McClain. !***END PROLOGUE QC36J ! integer ll1 integer mm2 integer LUN, 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) REAL TOL, L1, L2, L3, M1, M2, M3, L1MIN, L1MAX, M2MIN, M2MAX, & DIFF(NDIM), R1MACH, X, JJVAL, JMVAL, THRCOF(NDIM), & ! SIXCOF(NDIM), R3JJ(8), R3JM(14), R6J(15) DATA R3JJ / 2.78886675511358515993E-1, & -9.53462589245592315447E-2, & -6.74199862463242086246E-2, & 1.53311035167966641297E-1, & -1.56446554693685969725E-1, & 1.09945041215655051079E-1, & -5.53623569313171943334E-2, & ! 1.79983545113778583298E-2/ DATA R3JM / 2.09158973288615242614E-2, & 8.53756555321524722127E-2, & 9.08295370868692516943E-2, & -3.89054377846499391700E-2, & -6.63734970165680635691E-2, & 6.49524040528389395031E-2, & 2.15894310595403759392E-2, & -7.78912711785239219992E-2, & 3.59764371059543401880E-2, & 5.47301500021263423079E-2, & -7.59678665956761514629E-2, & -2.19224445539892113776E-2, & 1.01167744280772202424E-1, & ! 7.34825726244719704696E-2/ DATA R6J / 3.49090513837329977746E-2, & -3.74302503965979160859E-2, & 1.89086639095956018415E-2, & 7.34244825492864345709E-3, & -2.35893518508179445858E-2, & 1.91347695521543652000E-2, & 1.28801739772417220844E-3, & -1.93001836629052653977E-2, & 1.67730594938288876974E-2, & 5.50114727485094871674E-3, & -2.13543979089683097421E-2, & 3.46036445143538730828E-3, & 2.52095005479558458604E-2, & 1.48399056122171330285E-2, & ! !***FIRST EXECUTABLE STATEMENT QC36J ! ! --- INITIALIZATION OF TESTS 2.70857768063318559724E-3/ TOL=100.0*R1MACH(3) if ( KPRINT >= 2 ) then write (LUN,*)' THIS IS QC36J, A TEST PROGRAM FOR THE ' // & 'SINGLE PRECISION 3J6J PACKAGE.' write (LUN,*)' AN EXPLANATION OF THE VARIOUS ' // & 'TESTS CAN BE FOUND IN THE PROGRAM COMMENTS.' write (LUN,*) ! ! FIND NUMBER OF SIGNIFICANT FIGURES FOR FORMATTING. ! end if X=1.0/3.0 write (STRING,100)X 100 FORMAT(F35.25) DO 200 I=1,35 if ( STRING(I:I) == '3' ) then FIRST=I GOTO 300 end if 200 continue 300 continue DO I=FIRST,35 if ( STRING(I:I) /= '3' ) then LAST=I-1 GOTO 500 end if end do LAST=36 500 continue 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 RC3JJ VALUES WITH FORMULA ! FMT2(13:13)=')' IPASS1=1 L2=4.5 L3=3.5 M2=-3.5 M3=2.5 call RC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IER) if ( IER /= 0 ) then IPASS1=0 else l1 = l1min index = 1 do while ( l1 <= l1max ) M1=1.0 DIFF(INDEX)=ABS(THRCOF(INDEX)-R3JJ(INDEX)) if ( DIFF(INDEX) > ABS(R3JJ(INDEX))*TOL)IPASS1=0 l1 = l1 + 1.0D+00 index = index + 1 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 RC3JJ 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 ', & 'RC3JJ: IER =',IER else write (LUN,800) 800 FORMAT(' L1',T31,' RC3JJ VALUE',T67,'FORMULA VALUE') l1 = l1min index = 1 do while ( l1 <= l1max ) 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 l1 = l1 + 1.0D+00 index = index + 1 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 RC3JM VALUES WITH FORMULA ! IPASS2=1 L1=8.0 L2=7.5 L3=6.5 M1=1.0 call RC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) if ( IER /= 0 ) then IPASS2=0 else m2 = m2min index = 1 do while ( m2 <= m2max ) M3=-M1-M2 DIFF(INDEX)=ABS(THRCOF(INDEX)-R3JM(INDEX)) if ( DIFF(INDEX) > ABS(R3JM(INDEX))*TOL)IPASS2=0 m2 = m2 + 1.0D+00 index = index + 1 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 RC3JM 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 ', & 'RC3JM: IER =',IER else write (LUN,1200) 1200 FORMAT(' M2',T31,' RC3JM VALUE',T67,'FORMULA VALUE') m2 = m2min index = 1 do while ( m2 <= m2max ) 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 m2 = m2 + 1.0D+00 index = index + 1 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 RC3JJ AND RC3JM ! IPASS3=1 L1=100.0 L2=2.0 L3=100.0 M1=-10.0 M2=0.0 M3=10.0 call RC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IERJJ) JJVAL=THRCOF(3) call RC3JM(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 RC3JJ AND RC3JM' 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 ', & 'RC3JJ: IER =',IERJJ elseif ( IERJM /= 0 ) then write (LUN,*)' ERROR RETURNED FROM SUBROUTINE ', & 'RC3JM: IER =',IERJM else write (LUN,FMT2)'RC3JJ VALUE =',JJVAL write (LUN,FMT2)'RC3JM 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 RC6J VALUES WITH FORMULA ! IPASS4=1 L2=8.0 L3=7.0 M1=6.5 M2=7.5 M3=7.5 call RC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) if ( IER /= 0 ) then IPASS4=0 else l1 = l1min index = 1 do while ( l1 <= l1max ) DIFF(INDEX)=ABS(SIXCOF(INDEX)-R6J(INDEX)) if ( DIFF(INDEX) > ABS(R6J(INDEX))*TOL)IPASS4=0 l1 = l1 + 1.0D+00 index = index + 1 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 RC6J 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 ', & 'RC6J: IER =',IER else write (LUN,1320) 1320 FORMAT(' L1',T32,' RC6J VALUE',T67,'FORMULA VALUE') l1 = l1min index = 1 do while ( l1 <= l1max ) 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 l1 = l1 + 1.0D+00 index = index + 1 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 if ( KPRINT >= 3)WRITE(LUN,*)' TEST 5, CHECK FOR PROPER HANDLING ', & ! --- RC3JJ: L2-ABS(M2) OR L3-ABS(M3) LESS THAN ZERO (IER=1) 'OF INVALID INPUT' L2=2.0 L3=100.0 M1=-6.0 M2=-4.0 M3=10.0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call RC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IER) ! --- RC3JJ: L2+ABS(M2) OR L3+ABS(M3) NOT INTEGER (IER=2) if ( NUMXER(NERR) /= IER)IPASS5=0 L2=2.0 L3=99.5 M1=-10.0 M2=0.0 M3=10.0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call RC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IER) ! --- RC3JJ: L1MAX-L1MIN NOT INTEGER (IER=3) if ( NUMXER(NERR) /= IER)IPASS5=0 L2=3.2 L3=4.5 M1=-1.3 M2=0.8 M3=0.5 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call RC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IER) ! --- RC3JJ: L1MIN GREATER THAN L1MAX (IER=4) ! (NO TEST -- THIS ERROR SHOULD NEVER OCCUR) ! --- RC3JJ: DIMENSION OF THRCOF TOO SMALL (IER=5) if ( NUMXER(NERR) /= IER)IPASS5=0 L2=10.0 L3=150.0 M1=-10.0 M2=0.0 M3=10.0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call RC3JJ(L2,L3,M2,M3,L1MIN,L1MAX,THRCOF,NDIM,IER) ! --- RC3JM: L1-ABS(M1) LESS THAN ZERO OR L1+ABS(M1) NOT INTEGER (IER=1) if ( NUMXER(NERR) /= IER)IPASS5=0 L1=100.0 L2=2.0 L3=100.0 M1=150.0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call RC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) ! --- RC3JM: L1, L2, L3 DO NOT SATISFY TRIANGULAR CONDITION (IER=2) if ( NUMXER(NERR) /= IER)IPASS5=0 L1=20.0 L2=5.0 L3=10.0 M1=-10.0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call RC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) ! --- RC3JM: L1+L2+L3 NOT INTEGER (IER=3) if ( NUMXER(NERR) /= IER)IPASS5=0 L1=1.0 L2=1.3 L3=1.5 M1=0.0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call RC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) ! --- RC3JM: M2MAX-M2MIN NOT INTEGER (IER=4) if ( NUMXER(NERR) /= IER)IPASS5=0 L1=1.0 L2=1.3 L3=1.7 M1=0.0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call RC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) ! --- RC3JM: M2MIN GREATER THAN M2MAX (IER=5) ! (NO TEST -- THIS ERROR SHOULD NEVER OCCUR) ! --- RC3JM: DIMENSION OF THRCOF TOO SMALL (IER=6) if ( NUMXER(NERR) /= IER)IPASS5=0 L1=100.0 L2=10.0 L3=110.0 M1=-10.0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call RC3JM(L1,L2,L3,M1,M2MIN,M2MAX,THRCOF,NDIM,IER) ! --- RC6J: L2+L3+L5+L6 OR L4+L2+L6 NOT INTEGER (IER=1) if ( NUMXER(NERR) /= IER)IPASS5=0 L2=0.5 L3=1.0 M1=0.5 M2=2.0 M3=3.0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call RC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) ! --- RC6J: L4, L2, L6 TRIANGULAR CONDITION NOT SATISFIED (IER=2) if ( NUMXER(NERR) /= IER)IPASS5=0 L2=1.0 L3=3.0 M1=5.0 M2=6.0 M3=2.0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call RC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) ! --- RC6J: L4, L5, L3 TRIANGULAR CONDITION NOT SATISFIED (IER=3) if ( NUMXER(NERR) /= IER)IPASS5=0 L2=4.0 L3=1.0 M1=5.0 M2=3.0 M3=2.0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call RC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) ! --- RC6J: L1MAX-L1MIN NOT INTEGER (IER=4) if ( NUMXER(NERR) /= IER)IPASS5=0 L2=0.9 L3=0.5 M1=0.9 M2=0.4 M3=0.2 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call RC6J(L2,L3,M1,M2,M3,L1MIN,L1MAX,SIXCOF,NDIM,IER) ! --- RC6J: L1MIN GREATER THAN L1MAX (IER=5) ! (NO TEST -- THIS ERROR SHOULD NEVER OCCUR) ! --- RC6J: DIMENSION OF SIXCOF TOO SMALL (IER=6) if ( NUMXER(NERR) /= IER)IPASS5=0 L2=50.0 L3=25.0 M1=15.0 M2=30.0 M3=40.0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call RC6J(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 OF TESTS 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(' ***** QC36J FAILED SOME TESTS *****') ! 1600 FORMAT(' ***** QC36J PASSED ALL TESTS *****') return end !! QC6A !***PURPOSE Test subroutine AAAAAA. !***LIBRARY SLATEC !***TYPE ALL (QC6A-A) !***AUTHOR Boland, W. Robert, (LANL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call QC6A (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: ! ! This routine tests the SLATEC routine AAAAAA to see if the version ! number in the SLATEC library source is the same as the quick check ! version number. ! !***ROUTINES CALLED AAAAAA !***REVISION HISTORY (YYMMDD) ! 890713 DATE WRITTEN ! 921215 Updated for Version 4.0. (WRB) ! 930701 Updated for Version 4.1. (WRB) !***END PROLOGUE QC6A ! !*Internal Notes: ! ! Data set-up is done via a PARAMETER statement. ! !**End ! ! Declare arguments. ! subroutine QC6A (LUN, KPRINT, IPASS) ! ! DECLARE VARIABLES. ! integer LUN, KPRINT, IPASS CHARACTER * 16 VER, VERSN ! !***FIRST EXECUTABLE STATEMENT QC6A PARAMETER (VERSN = ' 4.1') if ( KPRINT >= 3) write (LUN, 9000) call AAAAAA (VER) if ( VER == VERSN ) then ipass = 1 if ( kprint >= 3 ) then write (LUN, 9010) write (LUN, 9020) VER end if else ipass = 0 if ( kprint >= 3) write (LUN, 9010) if ( kprint >= 2) write (LUN, 9030) VER, VERSN ! ! Terminate. ! end if if ( KPRINT >= 2 .and. ipass == 1) write (LUN, 90000) if ( KPRINT >= 1 .and. ipass == 0) write (LUN, 90010) ! ! Formats. ! return 9000 FORMAT ('1' // ' CODE TO TEST SLATEC ROUTINE AAAAAA') 9010 FORMAT (/ ' QC6A RESULTS') 9020 FORMAT (' *** Passed -- version number = ', A16) 9030 FORMAT (' *** Failed -- version number from AAAAAA = ', A16, & ' but expected version number = ', A16) 90000 FORMAT(/' ************QC6A PASSED ALL TESTS ****************') ! -------- LAST LINE OF QC6A FOLLOWS ----------------------------- 90010 FORMAT(/' ************QC6A FAILED SOME TESTS ****************') end !! QCDRC !***PURPOSE Quick check for DRC. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Pexton, R. L., (LLNL) !***DESCRIPTION ! ! QUICK TEST FOR CARLSON INTEGRAL DRC ! !***ROUTINES CALLED d1mach, DRC, NUMXER, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 910708 Minor modifications in use of KPRINT. (WRB) !***END PROLOGUE QCDRC subroutine QCDRC (LUN, KPRINT, IPASS) integer KPRINT, IPASS, CONTRL, KONTRL, LUN, IER integer IPASS1, IPASS2, IPASS3, IPASS4, NUMXER double precision PI, TRC, DRC, DIF, d1mach !***FIRST EXECUTABLE STATEMENT QCDRC EXTERNAL d1mach, DRC, NUMXER, XERCLR, XGETF, XSETF call xerclr call XGETF(CONTRL) if ( kprint >= 3 ) then KONTRL = +1 else KONTRL = 0 end if ! ! FORCE ERROR 1 ! call XSETF(KONTRL) if ( kprint >= 3 ) write (LUN,101) 101 FORMAT(' DRC - FORCE ERROR 1 TO OCCUR') TRC = DRC(-1.0D0,-1.0D0,IER) IER = NUMXER(IER) if ( IER == 1 ) then IPASS1 = 1 else IPASS1 = 0 end if ! ! FORCE ERROR 2 ! call xerclr if ( kprint >= 3 ) write (LUN,102) 102 FORMAT(' DRC - FORCE ERROR 2 TO OCCUR') TRC = DRC(d1mach(1),d1mach(1),IER) IER = NUMXER(IER) if ( IER == 2 ) then IPASS2 = 1 else IPASS2 = 0 end if ! ! FORCE ERROR 3 ! call xerclr if ( kprint >= 3 ) write (LUN,103) 103 FORMAT(' DRC - FORCE ERROR 3 TO OCCUR') TRC = DRC(d1mach(2),d1mach(2),IER) IER = NUMXER(IER) if ( IER == 3 ) then IPASS3 = 1 else IPASS3 = 0 end if ! ! ARGUMENTS IN RANGE ! call xerclr PI = 3.141592653589793238462643383279D0 TRC = DRC(0.0D0,0.25D0,IER) call xerclr DIF = TRC - PI if ( (ABS(DIF/PI) < 1000.0D0*d1mach(4)) .and. (IER == 0) ) then IPASS4 = 1 else IPASS4 = 0 end if ipass = min ( IPASS1,IPASS2,IPASS3,IPASS4) if ( kprint <= 0 ) then GO TO 999 elseif ( kprint == 1 ) then if ( ipass == 1 ) then GO TO 999 else write (LUN,104) 104 FORMAT(' DRC - FAILED') GO TO 999 end if else if ( ipass == 1 ) then write (LUN,105) 105 FORMAT(' DRC - PASSED') GO TO 999 else write (LUN,104) if ( IPASS4 == 0 ) write (LUN,106) PI, TRC, DIF 106 FORMAT(' CORRECT ANSWER =', 1PD20.14 / & 'COMPUTED ANSWER =', D20.14 / & ' DIFFERENCE =', D20.14 ) GO TO 999 end if end if 999 continue call XSETF(CONTRL) return end !! QCDRD !***PURPOSE Quick check for DRD. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Pexton, R. L., (LLNL) !***DESCRIPTION ! ! QUICK TEST FOR CARLSON INTEGRAL DRD ! !***ROUTINES CALLED d1mach, DRD, NUMXER, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 910708 Minor modifications in use of KPRINT. (WRB) ! 930214 Added more digits to BLEM. (WRB) !***END PROLOGUE QCDRD subroutine QCDRD (LUN, KPRINT, IPASS) integer KPRINT, IPASS, CONTRL, KONTRL, LUN, IER integer IPASS1, IPASS2, IPASS3, IPASS4, NUMXER double precision BLEM, TRD, DRD, DIF, d1mach !***FIRST EXECUTABLE STATEMENT QCDRD EXTERNAL d1mach, DRD, NUMXER, XERCLR, XGETF, XSETF call xerclr call XGETF(CONTRL) if ( kprint >= 3 ) then KONTRL = +1 else KONTRL = 0 end if ! ! FORCE ERROR 1 ! call XSETF(KONTRL) if ( kprint >= 3 ) write (LUN,101) 101 FORMAT(' DRD - FORCE ERROR 1 TO OCCUR') TRD = DRD(-1.0D0,-1.0D0,-1.0D0,IER) IER = NUMXER(IER) if ( IER == 1 ) then IPASS1 = 1 else IPASS1 = 0 end if ! ! FORCE ERROR 2 ! call xerclr if ( kprint >= 3 ) write (LUN,102) 102 FORMAT(' DRD - FORCE ERROR 2 TO OCCUR') TRD = DRD(1.0D0,1.0D0,-1.0D0,IER) IER = NUMXER(IER) if ( IER == 2 ) then IPASS2 = 1 else IPASS2 = 0 end if ! ! FORCE ERROR 3 ! call xerclr if ( kprint >= 3 ) write (LUN,103) 103 FORMAT(' DRD - FORCE ERROR 3 TO OCCUR') TRD = DRD(d1mach(2),d1mach(2),D1MACH(2),IER) IER = NUMXER(IER) if ( IER == 3 ) then IPASS3 = 1 else IPASS3 = 0 end if ! ! ARGUMENTS IN RANGE ! BLEM=3 * LEMNISCATE CONSTANT B ! call xerclr BLEM = 1.797210352103388311159883738420485817341D0 TRD = DRD(0.0D0,2.0D0,1.0D0,IER) call xerclr DIF = TRD - BLEM if ( (ABS(DIF/BLEM) < 1000.0D0*d1mach(4)) .and. (IER == 0) ) then IPASS4 = 1 else ipass = 0 end if ipass = min ( IPASS1,IPASS2,IPASS3,IPASS4) if ( kprint <= 0 ) then GO TO 999 elseif ( kprint == 1 ) then if ( ipass == 1 ) then GO TO 999 else write (LUN,104) 104 FORMAT(' DRD - FAILED') GO TO 999 end if else if ( ipass == 1 ) then write (LUN,105) 105 FORMAT(' DRD - PASSED') GO TO 999 else write (LUN,104) if ( IPASS4 == 0 ) write (LUN,106) BLEM, TRD, DIF 106 FORMAT(' CORRECT ANSWER =', 1PD20.14 / & 'COMPUTED ANSWER =', D20.14 / & ' DIFFERENCE =', D20.14 ) GO TO 999 end if end if 999 continue call XSETF(CONTRL) return end !! QCDRF !***PURPOSE Quick check for DRF. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Pexton, R. L., (LLNL) !***DESCRIPTION ! ! QUICK TEST FOR CARLSON INTEGRAL DRF ! !***ROUTINES CALLED d1mach, DRF, NUMXER, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 910708 Minor modifications in use of KPRINT. (WRB) ! 930214 Added more digits to ALEM. (WRB) !***END PROLOGUE QCDRF subroutine QCDRF (LUN, KPRINT, IPASS) integer KPRINT, IPASS, CONTRL, KONTRL, LUN, IER integer IPASS1, IPASS2, IPASS3, IPASS4, NUMXER double precision ALEM, TRF, DRF, DIF, d1mach !***FIRST EXECUTABLE STATEMENT QCDRF EXTERNAL d1mach, DRF, NUMXER, XERCLR, XGETF, XSETF call xerclr call XGETF(CONTRL) if ( kprint >= 3 ) then KONTRL = +1 else KONTRL = 0 end if ! ! FORCE ERROR 1 ! call XSETF(KONTRL) if ( kprint >= 3 ) write (LUN,101) 101 FORMAT(' DRF - FORCE ERROR 1 TO OCCUR') TRF = DRF(-1.0D0,-1.0D0,-1.0D0,IER) IER = NUMXER(IER) if ( IER == 1 ) then IPASS1 = 1 else IPASS1 = 0 end if ! ! FORCE ERROR 2 ! call xerclr if ( kprint >= 3 ) write (LUN,102) 102 FORMAT(' DRF - FORCE ERROR 2 TO OCCUR') TRF = DRF(d1mach(1),d1mach(1),D1MACH(1),IER) IER = NUMXER(IER) if ( IER == 2 ) then IPASS2 = 1 else IPASS2 = 0 end if ! ! FORCE ERROR 3 ! call xerclr if ( kprint >= 3 ) write (LUN,103) 103 FORMAT(' DRF - FORCE ERROR 3 TO OCCUR') TRF = DRF(d1mach(2),d1mach(2),D1MACH(2),IER) IER = NUMXER(IER) if ( IER == 3 ) then IPASS3 = 1 else IPASS3 = 0 end if ! ! ARGUMENTS IN RANGE ! ALEM=LEMNISCATE CONSTANT A ! call xerclr ALEM = 1.3110287771460599052324197949455597068D0 TRF = DRF(0.0D0,1.0D0,2.0D0,IER) call xerclr DIF = TRF - ALEM if ( (ABS(DIF/ALEM) < 1000.0D0*d1mach(4)) .and. (IER == 0) ) then IPASS4 = 1 else IPASS4 = 0 end if ipass = min ( IPASS1,IPASS2,IPASS3,IPASS4) if ( kprint == 0 ) then GO TO 999 elseif ( kprint == 1 ) then if ( ipass == 1 ) then GO TO 999 else write (LUN,104) 104 FORMAT(' DRF - FAILED') GO TO 999 end if else if ( ipass == 1 ) then write (LUN,105) 105 FORMAT(' DRF - PASSED') GO TO 999 else write (LUN,104) if ( IPASS4 == 0 ) write (LUN,106) ALEM, TRF, DIF 106 FORMAT(' CORRECT ANSWER =', 1PD20.14 / & 'COMPUTED ANSWER =', D20.14 / & ' DIFFERENCE =', D20.14 ) GO TO 999 end if end if 999 continue call XSETF(CONTRL) return end !! QCDRJ !***PURPOSE Quick check for DRJ. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Pexton, R. L., (LLNL) !***DESCRIPTION ! ! QUICK TEST FOR CARLSON INTEGRAL DRJ ! !***ROUTINES CALLED d1mach, DRJ, NUMXER, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 910708 Minor modifications in use of KPRINT. (WRB) ! 930214 Added more digits to CONSJ. (WRB) !***END PROLOGUE QCDRJ subroutine QCDRJ (LUN, KPRINT, IPASS) integer KPRINT, IPASS, CONTRL, KONTRL, LUN, IER integer IPASS1, IPASS2, IPASS3, IPASS4, NUMXER double precision CONSJ, TRJ, DRJ, DIF, d1mach !***FIRST EXECUTABLE STATEMENT QCDRJ EXTERNAL d1mach, DRJ, NUMXER, XERCLR, XGETF, XSETF call xerclr call XGETF(CONTRL) if ( kprint >= 3 ) then KONTRL = +1 else KONTRL = 0 end if ! ! FORCE ERROR 1 ! call XSETF(KONTRL) if ( kprint >= 3 ) write (LUN,101) 101 FORMAT(' DRJ - FORCE ERROR 1 TO OCCUR') TRJ = DRJ(-1.0D0,-1.0D0,-1.0D0,-1.0D0,IER) IER = NUMXER(IER) if ( IER == 1 ) then IPASS1 = 1 else IPASS1 = 0 end if ! ! FORCE ERROR 2 ! call xerclr if ( kprint >= 3 ) write (LUN,102) 102 FORMAT(' DRJ - FORCE ERROR 2 TO OCCUR') TRJ = DRJ(d1mach(1),d1mach(1),D1MACH(1),D1MACH(1),IER) IER = NUMXER(IER) if ( IER == 2 ) then IPASS2 = 1 else IPASS2 = 0 end if ! ! FORCE ERROR 3 ! call xerclr if ( kprint >= 3 ) write (LUN,103) 103 FORMAT(' DRJ - FORCE ERROR 3 TO OCCUR') TRJ = DRJ(d1mach(2),d1mach(2),D1MACH(2),D1MACH(2),IER) IER = NUMXER(IER) if ( IER == 3 ) then IPASS3 = 1 else IPASS3 = 0 end if ! ! ARGUMENTS IN RANGE ! call xerclr CONSJ = 0.14297579667156753833233879421985774801D0 TRJ = DRJ(2.0D0,3.0D0,4.0D0,5.0D0,IER) call xerclr DIF = TRJ - CONSJ if ( (ABS(DIF/CONSJ) < 1000.0D0*d1mach(4)) .and. (IER == 0) ) then IPASS4 = 1 else IPASS4 = 0 end if ipass = min ( IPASS1,IPASS2,IPASS3,IPASS4) if ( kprint <= 0 ) then GO TO 999 elseif ( kprint == 1 ) then if ( ipass == 1 ) then GO TO 999 else write (LUN,104) 104 FORMAT(' DRJ - FAILED') GO TO 999 end if else if ( ipass == 1 ) then write (LUN,105) 105 FORMAT(' DRJ - PASSED') GO TO 999 else write (LUN,104) if ( IPASS4 == 0 ) write (LUN,106) CONSJ, TRJ, DIF 106 FORMAT(' CORRECT ANSWER =', 1PD20.14 / & 'COMPUTED ANSWER =', D20.14 / & ' DIFFERENCE =', D20.14 ) GO TO 999 end if end if 999 continue call XSETF(CONTRL) return end !! QCGLSS !***PURPOSE Quick check for SGLSS. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (QCGLSS-S, DQCGLS-D) !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! QUICK CHECK SUBROUTINE QCGLSS TESTS THE EXECUTION ! OF THE GENERAL LINEAR SYSTEM SOLVER, SGLSS . THE ! SGLSS SUBROUTINE PACKAGE WAS WRITTEN BY T. MANTEUFFEL ! (LANL). ! ! A TITLE LINE AND A SUMMARY LINE ARE ALWAYS OUTPUTTED ! BY QCGLSS. 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(R1MACH(4) OR MORE. THE RETURNED VALUE (INTEGER) ! OF INFO IS ALSO CHECKED. FOUR CASES ARE RUN, TWO ! INVOLVING LLSIA AND TWO INVOLVING ULSIA . ! ! QCGLSS REQUIRES NO INPUT ARGUMENTS. ON RETURN, NERR ! (INTEGER TYPE) CONTAINS THE COUNT OF THE NUMBER OF ! PROBLEMS DETECTED BY QCGLSS . ! !***ROUTINES CALLED R1MACH, SGLSS !***REVISION HISTORY (YYMMDD) ! 811026 DATE WRITTEN ! 820801 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 QCGLSS subroutine QCGLSS (LUN, KPRINT, IPASS) REAL AA(4,4,2),A(4,4),BB(4,2),B(4),XX(4,4),DELMAX,DELX,R REAL WORK(20) CHARACTER*1 LIST(2) integer INF(4),NERR,KPROG,KCASE integer IWORK(7),INFO,LUN DATA AA/1.,.5,1.,.25,0.,2.,0.,1.,2.,-1.,1.,0.,0.,0.,0.,0., & 1.,2.,-1.,0.,0.,1.,2.,0.,-1.,0.,1.,0.,1.,0.,1.,0./ DATA BB/3.,1.5,2.,1.25,1.,3.,3.,0./ DATA XX/.9999999999999787,1.000000000000007,1.000000000000007, & 0.,.8095238095238102,1.047619047619044,1.095238095238081,0., & .7777777777777857,1.444444444444429,.3333333333333393, & .5555555555555500, & .3333333333333321,0.0,-.3333333333333286,.3333333333333286/ DATA INF/0,1,0,2/ !***FIRST EXECUTABLE STATEMENT QCGLSS DATA LIST/'L','U'/ INFO = 0 NERR = 0 R = SQRT(R1MACH(4)) 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 5 J=1,4 A(I,J) = AA(I,J,KPROG) 5 continue B(I) = BB(I,KPROG) ! ! MAKE 3 ROWS IDENTICAL FOR CASE 2. ! 10 continue if ( KCASE /= 1 ) then DO 20 I=2,3 DO 15 J=1,4 A(I,J) = A(1,J) 15 continue B(I) = B(1) 20 continue ! ! SOLVE FOR VECTOR X . ! end if INFO = 0 if ( KPROG == 1) call SGLSS(A,4,4,3,B,4,1,RNORM,WORK,20, & IWORK,7,INFO) if ( KPROG == 2) call SGLSS(A,4,3,4,B,4,1,RNORM,WORK,20, & ! ! TEST COMPUTED X , RNORM , AND INFO . ! IWORK,7,INFO) KK = 2*(KPROG - 1) + KCASE DELMAX = 0.0E0 DO 30 I=1,4 DELX = ABS(B(I)-XX(I,KK)) DELMAX = max ( DELMAX,DELX) ! 30 continue 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 701 FORMAT (3X, A, 'LSIA, CASE ', I1, '. MAX ABS ERROR OF', E11.4/) 702 FORMAT (3X, A, 'LSIA, CASE ', I1, '. RNORM IS ', E11.4/) 703 FORMAT (3X, A, 'LSIA, CASE ', I1, '. INFO=', I1, & ' (SHOULD = ', I1, ')'/) 800 FORMAT(/' * QCGLSS - QUICK CHECK FOR SGLSS (LLSIA AND ULSIA)'/) 801 FORMAT (' PROBLEM WITH ', A, 'LSIA, CASE ', I1, & '. MAX ABS ERROR OF', E11.4/) 802 FORMAT (' PROBLEM WITH ', A, 'LSIA, CASE ', I1, & '. RNORM (TOO LARGE) IS', E11.4/) 803 FORMAT (' PROBLEM WITH ', A, 'LSIA, CASE ', I1, & '. INFO=', I1, ' (SHOULD = ', I1, ')'/) 804 FORMAT (/' **** QCGLSS DETECTED A TOTAL OF ', I2, & ' PROBLEMS WITH SGLSS. ****'/) 805 FORMAT (' QCGLSS DETECTED NO PROBLEMS WITH SGLSS.'/) end !! QCKIN !***PURPOSE Quick check for BSKIN. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! ABSTRACT ! QCKIN IS A QUICK CHECK ROUTINE WHICH EXERCISES THE MAJOR ! LOOPS IN SUBROUTINE BSKIN (X,N,KODE,M,Y,NZ,IERR) FOR BICKLEY ! FUNCTIONS KI(J,X). MORE PRECISELY, QCKIN DOES CONSISTENCY CHECKS ! ON THE OUTPUT FROM BSKIN BY COMPARING SINGLE EVALUATIONS (M=1) ! AGAINST SELECTED MEMBERS OF SEQUENCES WHICH ARE GENERATED BY ! RECURSION. IF THE RELATIVE ERROR IS LESS THAN 1000 TIMES UNIT ! ROUND OFF, THEN THE TEST IS PASSED - IF NOT, THEN X, THE VALUES ! TO BE COMPARED, THE RELATIVE ERROR AND PARAMETERS KODE, N, M AND K ! ARE WRITTEN ON LOGICAL UNIT 6 WHERE K IS THE MEMBER OF THE ! SEQUENCE OF LENGTH M WHICH FAILED THE TEST. THAT IS, THE INDEX ! OF THE FUNCTION WHICH FAILED THE TEST IS J=N+K-1. UNDERFLOW ! TESTS ARE MADE AND ERROR CONDITIONS ARE TRIGGERED. ! ! FUNCTIONS i1mach AND R1MACH MUST BE INITIALIZED ACCORDING TO THE ! PROLOGUE IN EACH FUNCTION FOR THE MACHINE ENVIRONMENT BEFORE ! QCKIN OR BSKIN CAN BE EXECUTED. FIFTEEN MACHINE ENVIRONMENTS ! CAN BE DEFINED IN i1mach AND R1MACH. ! !***ROUTINES CALLED BSKIN, i1mach, R1MACH !***REVISION HISTORY (YYMMDD) ! 820601 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 QCKIN subroutine QCKIN (LUN, KPRINT, IPASS) integer I, IERR, IFLG, IX, I1M12, J, K, KODE, LUN, M, MDEL, MM, & N, NDEL, NN, NZ integer i1mach REAL AIX, ER, TOL, V, X, XINC, Y REAL R1MACH !***FIRST EXECUTABLE STATEMENT QCKIN dimension V(1), Y(10) TOL = 1000.0E0*MAX(R1MACH(4),1.0E-18) IFLG = 0 if ( KPRINT >= 3)WRITE (LUN,99999) 99999 FORMAT (1H1//34H QUICK CHECK DIAGNOSTICS FOR BSKIN//) DO 70 KODE=1,2 N = 0 DO 60 NN=1,7 M = 1 DO 50 MM=1,4 X = 0.0E0 DO 40 IX=1,6 if ( N == 0 .and. IX == 1) GO TO 30 call BSKIN(X, N, KODE, M, Y, NZ, IERR) DO 20 K=1,M,2 J = N + K - 1 call BSKIN(X, J, KODE, 1, V, NZ, IERR) ER = ABS((V(1)-Y(K))/V(1)) if ( ER <= TOL) GO TO 20 if ( IFLG /= 0) GO TO 10 if ( KPRINT >= 2)WRITE (LUN,99998) 99998 FORMAT (8X, 1HX, 13X, 4HV(1), 11X, 4HY(K), 9X, 6HREL ER, & 1HR, 5X, 4HKODE, 3X, 1HN, 4X, 1HM, 4X, 1HK) 10 continue IFLG = IFLG + 1 if ( KPRINT >= 2) & write (LUN,99997) X, V(1), Y(K), ER, KODE, N, M, K 99997 FORMAT (4E15.6, 4I5) if ( IFLG > 200) GO TO 130 20 continue 30 continue AIX = 2*IX-3 XINC = max ( 1.0E0,AIX) X = X + XINC 40 continue MDEL = max ( 1,MM-1) M = M + MDEL 50 continue NDEL = max ( 1,2*N-2) N = N + NDEL 60 continue ! ------------------------------------------------------------------ ! TEST UNDERFLOW ! ------------------------------------------------------------------ 70 continue KODE = 1 M = 10 N = 10 I1M12 = i1mach(12) X = -2.302E0*R1MACH(5)*I1M12 call BSKIN(X, N, KODE, M, Y, NZ, IERR) if ( NZ == M) GO TO 80 if ( KPRINT >= 2)WRITE (LUN,99996) 99996 FORMAT (//30H NZ IN UNDERFLOW TEST IS NOT 1//) IFLG = IFLG + 1 GO TO 110 80 continue DO 90 I=1,M if ( Y(I) /= 0.0E0) GO TO 100 90 continue GO TO 110 100 continue IFLG = IFLG + 1 if ( KPRINT >= 2)WRITE (LUN,99995) 99995 FORMAT (//43H SOME Y VALUE IN UNDERFLOW TEST IS NOT ZERO//) 110 continue if ( IFLG /= 0.OR.KPRINT < 3) GO TO 120 write (LUN,99994) 99994 FORMAT (//16H QUICK CHECKS OK//) 120 continue IPASS=0 if ( IFLG == 0) IPASS=1 return 130 continue if ( KPRINT >= 2)WRITE (LUN,99992) 99992 FORMAT (//52H PROCESSING OF MAIN LOOPS TERMINATED BECAUSE THE NUM, & 36HBER OF DIAGNOSTIC PRINTS EXCEEDS 200//) IPASS=0 if ( IFLG == 0) IPASS=1 return end !! QCPSI !***PURPOSE Quick check for PSIFN. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Amos, D. E., (SNLA) !***DESCRIPTION ! ! ABSTRACT ! QCPSI IS A QUICK CHECK ROUTINE WHICH EXERCISES THE MAJOR ! LOOPS IN SUBROUTINE PSIFN(X,N,KODE,M,ANS,NZ,IERR) FOR DERIVATIVES ! OF THE PSI FUNCTION. FOR N=0, THE PSI FUNCTIONS ARE CALCULATED ! EXPLICITLY AND CHECKED AGAINST EVALUATIONS FROM PSIFN. FOR ! N > 0, CONSISTENCY CHECKS ARE MADE BY COMPARING A SEQUENCE ! AGAINST SINGLE EVALUATIONS OF PSIFN, ONE AT A TIME. ! IF THE RELATIVE ERROR IS LESS THAN 1000 TIMES UNIT ROUNDOFF, ! THEN THE TEST IS PASSED--IF NOT, ! THEN X, THE VALUES TO BE COMPARED, THE RELATIVE ERROR AND ! PARAMETERS KODE AND N ARE WRITTEN ON LOGICAL UNIT 6 WHERE N IS ! THE ORDER OF THE DERIVATIVE AND KODE IS A SELECTION PARAMETER ! DEFINED IN THE PROLOGUE TO PSIFN. ! ! FUNCTIONS i1mach AND R1MACH MUST BE INITIALIZED ACCORDING TO THE ! PROLOGUE IN EACH FUNCTION FOR THE MACHINE ENVIRONMENT BEFORE ! QCPSI OR PSIFN CAN BE EXECUTED. ! !***ROUTINES CALLED PSIFN, R1MACH !***REVISION HISTORY (YYMMDD) ! 820601 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 QCPSI subroutine QCPSI (LUN, KPRINT, IPASS) integer I, IERR, IFLG, IX, KODE, LUN, M, N, NM, NN, NZ REAL ER, EULER, PSI1, PSI2, R1M4, S, TOL, X REAL R1MACH dimension PSI1(3), PSI2(20) !***FIRST EXECUTABLE STATEMENT QCPSI DATA EULER /0.5772156649015328606E0/ R1M4 = R1MACH(4) TOL = 1000.0E0*MAX(R1M4,1.0E-18) if ( KPRINT >= 3)WRITE (LUN,99999) ! ------------------------------------------------------------------ ! CHECK PSI(I) AND PSI(I-0.5), I=1,2,... ! ------------------------------------------------------------------ 99999 FORMAT (1H1//34H QUICK CHECK DIAGNOSTICS FOR PSIFN//) IFLG = 0 N = 0 DO 50 KODE=1,2 DO 40 M=1,2 S = -EULER + (M-1)*(-2.0E0*LOG(2.0E0)) X = 1.0E0 - (M-1)*0.5E0 DO 30 I=1,20 call PSIFN(X, N, KODE, 1, PSI2, NZ, IERR) PSI1(1) = -S + (KODE-1)*LOG(X) ER = ABS((PSI1(1)-PSI2(1))/PSI1(1)) if ( ER <= TOL) GO TO 20 if ( IFLG /= 0) GO TO 10 if ( KPRINT >= 2)WRITE (LUN,99998) 99998 FORMAT (8X, 1HX, 13X, 4HPSI1, 11X, 4HPSI2, 9X, 7HREL ERR, & 5X, 4HKODE, 3X, 1HN) 10 continue IFLG = IFLG + 1 if ( KPRINT >= 2) & write (LUN,99997) X, PSI1(1), PSI2(I), ER, KODE, N 99997 FORMAT (4E15.6, 2I5) if ( IFLG > 200) GO TO 150 20 continue S = S + 1.0E0/X X = X + 1.0E0 30 continue 40 continue ! ------------------------------------------------------------------ ! CHECK SMALL X < UNIT ROUNDOFF ! ------------------------------------------------------------------ 50 continue KODE = 1 X = TOL/10000.0E0 N = 1 call PSIFN(X, N, KODE, 1, PSI2, NZ, IERR) PSI1(1) = X**(-N-1) ER = ABS((PSI1(1)-PSI2(1))/PSI1(1)) if ( ER <= TOL) GO TO 70 if ( IFLG /= 0) GO TO 60 if ( KPRINT >= 2)WRITE (LUN,99998) 60 continue IFLG = IFLG + 1 if ( KPRINT >= 2) & write (LUN,99997) X, PSI1(1), PSI2(1), ER, KODE, N ! ------------------------------------------------------------------ ! CONSISTENCY TESTS FOR N >= 0 ! ------------------------------------------------------------------ 70 continue DO 130 KODE=1,2 DO 120 M=1,5 DO 110 N=1,16,5 NN = N - 1 X = 0.1E0 DO 100 IX=1,25,2 X = X + 1.0E0 call PSIFN(X, NN, KODE, M, PSI2, NZ, IERR) DO 90 I=1,M NM = NN + I - 1 call PSIFN(X, NM, KODE, 1, PSI1, NZ, IERR) ER = ABS((PSI2(I)-PSI1(1))/PSI1(1)) if ( ER < TOL) GO TO 90 if ( IFLG /= 0) GO TO 80 if ( KPRINT >= 2)WRITE (LUN,99998) 80 continue IFLG = IFLG + 1 if ( KPRINT >= 2) & write (LUN,99997) X, PSI1(1), PSI2(I), ER, KODE, NM 90 continue 100 continue 110 continue 120 continue 130 continue if ( IFLG /= 0.OR.KPRINT < 3) GO TO 140 write (LUN,99996) 99996 FORMAT (//16H QUICK CHECKS OK//) 140 continue IPASS=0 if ( IFLG == 0)IPASS=1 return 150 continue if ( KPRINT >= 2)WRITE (LUN,99994) 99994 FORMAT (//52H PROCESSING OF MAIN LOOPS TERMINATED BECAUSE THE NUM, & 36HBER OF DIAGNOSTIC PRINTS EXCEEDS 200//) IPASS=0 if ( IFLG == 0)IPASS=1 return end !! QCRC !***PURPOSE Quick check for RC. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Pexton, R. L., (LLNL) !***DESCRIPTION ! ! QUICK TEST FOR CARLSON INTEGRAL RC ! !***ROUTINES CALLED NUMXER, R1MACH, RC, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 910708 Minor modifications in use of KPRINT. (WRB) !***END PROLOGUE QCRC subroutine QCRC (LUN, KPRINT, IPASS) integer KPRINT, IPASS, CONTRL, KONTRL, LUN, IER integer IPASS1, IPASS2, IPASS3, IPASS4, NUMXER REAL PI, TRC, RC, DIF, R1MACH !***FIRST EXECUTABLE STATEMENT QCRC EXTERNAL NUMXER, R1MACH, RC, XERCLR, XGETF, XSETF call xerclr call XGETF(CONTRL) if ( kprint >= 3 ) then KONTRL = +1 else KONTRL = 0 end if ! ! FORCE ERROR 1 ! call XSETF(KONTRL) if ( kprint >= 3 ) write (LUN,101) 101 FORMAT(' RC - FORCE ERROR 1 TO OCCUR') TRC = RC(-1.0E0,-1.0E0,IER) IER = NUMXER(IER) if ( IER == 1 ) then IPASS1 = 1 else IPASS1 = 0 end if ! ! FORCE ERROR 2 ! call xerclr if ( kprint >= 3 ) write (LUN,102) 102 FORMAT(' RC - FORCE ERROR 2 TO OCCUR') TRC = RC(R1MACH(1),R1MACH(1),IER) IER = NUMXER(IER) if ( IER == 2 ) then IPASS2 = 1 else IPASS2 = 0 end if ! ! FORCE ERROR 3 ! call xerclr if ( kprint >= 3 ) write (LUN,103) 103 FORMAT(' RC - FORCE ERROR 3 TO OCCUR') TRC = RC(R1MACH(2),R1MACH(2),IER) IER = NUMXER(IER) if ( IER == 3 ) then IPASS3 = 1 else IPASS3 = 0 end if ! ! ARGUMENTS IN RANGE ! call xerclr PI = 3.1415926535897932E0 TRC = RC(0.0E0,0.25E0,IER) call xerclr DIF = TRC - PI if ( (ABS(DIF/PI) < 1000.0E0*R1MACH(4)) .and. (IER == 0) ) then IPASS4 = 1 else IPASS4 = 0 end if ipass = min ( IPASS1,IPASS2,IPASS3,IPASS4) if ( kprint <= 0 ) then GO TO 999 elseif ( kprint == 1 ) then if ( ipass == 1 ) then GO TO 999 else write (LUN,104) 104 FORMAT(' RC - FAILED') GO TO 999 end if else if ( ipass == 1 ) then write (LUN,105) 105 FORMAT(' RC - PASSED') GO TO 999 else write (LUN,104) if ( IPASS4 == 0 ) write (LUN,106) PI, TRC, DIF 106 FORMAT(' CORRECT ANSWER =', 1PE14.6 / & 'COMPUTED ANSWER =', E14.6 / & ' DIFFERENCE =', E14.6 ) GO TO 999 end if end if 999 continue call XSETF(CONTRL) return end !! QCRD !***PURPOSE Quick check for RD. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Pexton, R. L., (LLNL) !***DESCRIPTION ! ! QUICK TEST FOR CARLSON INTEGRAL RD ! !***ROUTINES CALLED NUMXER, R1MACH, RD, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 910708 Minor modifications in use of KPRINT. (WRB) !***END PROLOGUE QCRD subroutine QCRD (LUN, KPRINT, IPASS) integer KPRINT, IPASS, CONTRL, KONTRL, LUN, IER integer IPASS1, IPASS2, IPASS3, IPASS4, NUMXER REAL BLEM, TRD, RD, DIF, R1MACH !***FIRST EXECUTABLE STATEMENT QCRD EXTERNAL NUMXER, R1MACH, RD, XERCLR, XGETF, XSETF call xerclr call XGETF(CONTRL) if ( kprint >= 3 ) then KONTRL = +1 else KONTRL = 0 end if ! ! FORCE ERROR 1 ! call XSETF(KONTRL) if ( kprint >= 3 ) write (LUN,101) 101 FORMAT(' RD - FORCE ERROR 1 TO OCCUR') TRD = RD(-1.0E0,-1.0E0,-1.0E0,IER) IER = NUMXER(IER) if ( IER == 1 ) then IPASS1 = 1 else IPASS1 = 0 end if ! ! FORCE ERROR 2 ! call xerclr if ( kprint >= 3 ) write (LUN,102) 102 FORMAT(' RD - FORCE ERROR 2 TO OCCUR') TRD = RD(1.0E0,1.0E0,-1.0E0,IER) IER = NUMXER(IER) if ( IER == 2 ) then IPASS2 = 1 else IPASS2 = 0 end if ! ! FORCE ERROR 3 ! call xerclr if ( kprint >= 3 ) write (LUN,103) 103 FORMAT(' RD - FORCE ERROR 3 TO OCCUR') TRD = RD(R1MACH(2),R1MACH(2),R1MACH(2),IER) IER = NUMXER(IER) if ( IER == 3 ) then IPASS3 = 1 else IPASS3 = 0 end if ! ! ARGUMENTS IN RANGE ! BLEM=3 * LEMNISCATE CONSTANT B ! call xerclr BLEM = 1.79721035210338831E0 TRD = RD(0.0E0,2.0E0,1.0E0,IER) call xerclr DIF = TRD - BLEM if ( (ABS(DIF/BLEM) < 1000.0E0*R1MACH(4)) .and. (IER == 0) ) then IPASS4 = 1 else ipass = 0 end if ipass = min ( IPASS1,IPASS2,IPASS3,IPASS4) if ( kprint <= 0 ) then GO TO 999 elseif ( kprint == 1 ) then if ( ipass == 1 ) then GO TO 999 else write (LUN,104) 104 FORMAT(' RD - FAILED') GO TO 999 end if else if ( ipass == 1 ) then write (LUN,105) 105 FORMAT(' RD - PASSED') GO TO 999 else write (LUN,104) if ( IPASS4 == 0 ) write (LUN,106) BLEM, TRD, DIF 106 FORMAT(' CORRECT ANSWER =', 1PE14.6 / & 'COMPUTED ANSWER =', E14.6 / & ' DIFFERENCE =', E14.6 ) GO TO 999 end if end if 999 continue call XSETF(CONTRL) return end !! QCRF !***PURPOSE Quick check for RF. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Pexton, R. L., (LLNL) !***DESCRIPTION ! ! QUICK TEST FOR CARLSON INTEGRAL RF ! !***ROUTINES CALLED NUMXER, R1MACH, RF, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 910708 Minor modifications in use of KPRINT. (WRB) !***END PROLOGUE QCRF subroutine QCRF (LUN, KPRINT, IPASS) integer KPRINT, IPASS, CONTRL, KONTRL, LUN, IER integer IPASS1, IPASS2, IPASS3, IPASS4, NUMXER REAL ALEM, TRF, RF, DIF, R1MACH !***FIRST EXECUTABLE STATEMENT QCRF EXTERNAL NUMXER, R1MACH, RF, XERCLR, XGETF, XSETF call xerclr call XGETF(CONTRL) if ( kprint >= 3 ) then KONTRL = +1 else KONTRL = 0 end if ! ! FORCE ERROR 1 ! call XSETF(KONTRL) if ( kprint >= 3 ) write (LUN,101) 101 FORMAT(' RF - FORCE ERROR 1 TO OCCUR') TRF = RF(-1.0E0,-1.0E0,-1.0E0,IER) IER = NUMXER(IER) if ( IER == 1 ) then IPASS1 = 1 else IPASS1 = 0 end if ! ! FORCE ERROR 2 ! call xerclr if ( kprint >= 3 ) write (LUN,102) 102 FORMAT(' RF - FORCE ERROR 2 TO OCCUR') TRF = RF(R1MACH(1),R1MACH(1),R1MACH(1),IER) IER = NUMXER(IER) if ( IER == 2 ) then IPASS2 = 1 else IPASS2 = 0 end if ! ! FORCE ERROR 3 ! call xerclr if ( kprint >= 3 ) write (LUN,103) 103 FORMAT(' RF - FORCE ERROR 3 TO OCCUR') TRF = RF(R1MACH(2),R1MACH(2),R1MACH(2),IER) IER = NUMXER(IER) if ( IER == 3 ) then IPASS3 = 1 else IPASS3 = 0 end if ! ! ARGUMENTS IN RANGE ! ALEM=LEMNISCATE CONSTANT A ! call xerclr ALEM = 1.311028777146059905E0 TRF = RF(0.0E0,1.0E0,2.0E0,IER) call xerclr DIF = TRF - ALEM if ( (ABS(DIF/ALEM) < 1000.0E0*R1MACH(4)) .and. (IER == 0) ) then IPASS4 = 1 else IPASS4 = 0 end if ipass = min ( IPASS1,IPASS2,IPASS3,IPASS4) if ( kprint == 0 ) then GO TO 999 elseif ( kprint == 1 ) then if ( ipass == 1 ) then GO TO 999 else write (LUN,104) 104 FORMAT(' RF - FAILED') GO TO 999 end if else if ( ipass == 1 ) then write (LUN,105) 105 FORMAT(' RF - PASSED') GO TO 999 else write (LUN,104) if ( IPASS4 == 0 ) write (LUN,106) ALEM, TRF, DIF 106 FORMAT(' CORRECT ANSWER =', 1PE14.6 / & 'COMPUTED ANSWER =', E14.6 / & ' DIFFERENCE =', E14.6 ) GO TO 999 end if end if 999 continue call XSETF(CONTRL) return end !! QCRJ !***PURPOSE Quick check for RJ. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Pexton, R. L., (LLNL) !***DESCRIPTION ! ! QUICK TEST FOR CARLSON INTEGRAL RJ ! !***ROUTINES CALLED NUMXER, R1MACH, RJ, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 790801 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 910708 Minor modifications in use of KPRINT. (WRB) !***END PROLOGUE QCRJ subroutine QCRJ (LUN, KPRINT, IPASS) integer KPRINT, IPASS, CONTRL, KONTRL, LUN, IER integer IPASS1, IPASS2, IPASS3, IPASS4, NUMXER REAL CONSJ, TRJ, RJ, DIF, R1MACH !***FIRST EXECUTABLE STATEMENT QCRJ EXTERNAL NUMXER, R1MACH, RJ, XERCLR, XGETF, XSETF call xerclr call XGETF(CONTRL) if ( kprint >= 3 ) then KONTRL = +1 else KONTRL = 0 end if ! ! FORCE ERROR 1 ! call XSETF(KONTRL) if ( kprint >= 3 ) write (LUN,101) 101 FORMAT(' RJ - FORCE ERROR 1 TO OCCUR') TRJ = RJ(-1.0E0,-1.0E0,-1.0E0,-1.0E0,IER) IER = NUMXER(IER) if ( IER == 1 ) then IPASS1 = 1 else IPASS1 = 0 end if ! ! FORCE ERROR 2 ! call xerclr if ( kprint >= 3 ) write (LUN,102) 102 FORMAT(' RJ - FORCE ERROR 2 TO OCCUR') TRJ = RJ(R1MACH(1),R1MACH(1),R1MACH(1),R1MACH(1),IER) IER = NUMXER(IER) if ( IER == 2 ) then IPASS2 = 1 else IPASS2 = 0 end if ! ! FORCE ERROR 3 ! call xerclr if ( kprint >= 3 ) write (LUN,103) 103 FORMAT(' RJ - FORCE ERROR 3 TO OCCUR') TRJ = RJ(R1MACH(2),R1MACH(2),R1MACH(2),R1MACH(2),IER) IER = NUMXER(IER) if ( IER == 3 ) then IPASS3 = 1 else IPASS3 = 0 end if ! ! ARGUMENTS IN RANGE ! call xerclr CONSJ = 0.142975796671567538E0 TRJ = RJ(2.0E0,3.0E0,4.0E0,5.0E0,IER) call xerclr DIF = TRJ - CONSJ if ( (ABS(DIF/CONSJ) < 1000.0E0*R1MACH(4)) .and. (IER == 0) ) then IPASS4 = 1 else IPASS4 = 0 end if ipass = min ( IPASS1,IPASS2,IPASS3,IPASS4) if ( kprint <= 0 ) then GO TO 999 elseif ( kprint == 1 ) then if ( ipass == 1 ) then GO TO 999 else write (LUN,104) 104 FORMAT(' RJ - FAILED') GO TO 999 end if else if ( ipass == 1 ) then write (LUN,105) 105 FORMAT(' RJ - PASSED') GO TO 999 else write (LUN,104) if ( IPASS4 == 0 ) write (LUN,106) CONSJ, TRJ, DIF 106 FORMAT(' CORRECT ANSWER =', 1PE14.6 / & 'COMPUTED ANSWER =', E14.6 / & ' DIFFERENCE =', E14.6 ) GO TO 999 end if end if 999 continue call XSETF(CONTRL) return end !! QG8TST !***PURPOSE Quick check for GAUS8. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (QG8TST-S, DQG8TS-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED FQD1, FQD2, GAUS8, R1MACH, 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) ! 910501 Added PURPOSE and TYPE records. (WRB) ! 910708 Minor modifications in use of KPRINT. (WRB) ! 920213 Code restructured to test GAUS8 for all values of KPRINT, ! second accuracy test added and testing of error returns ! revised. (WRB) !***END PROLOGUE QG8TST ! .. Scalar Arguments .. subroutine QG8TST (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN integer IERR, KONTRL REAL A, ANS, B, COR, ERR, REQ, TOL ! .. External Functions .. LOGICAL FATAL REAL FQD1, FQD2, R1MACH ! .. External Subroutines .. EXTERNAL FQD1, FQD2, R1MACH ! .. Intrinsic Functions .. EXTERNAL GAUS8, XGETF, XSETF !***FIRST EXECUTABLE STATEMENT QG8TST INTRINSIC ABS, ATAN, EXP, SQRT ! ! Initialize variables for testing. ! if ( kprint >= 2) write (LUN,FMT=9000) TOL = SQRT(R1MACH(4)) ! ! First accuracy test. ! ipass = 1 A = 1.0E0 B = 4.0E0 ERR = TOL/100.0E0 call GAUS8 (FQD1, A, B, ERR, ANS, IERR) COR = 2.0E0 if ( ABS(ANS-COR) <= TOL .and. IERR == 1 ) then if ( kprint >= 3) & write (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR else ipass = 0 if ( kprint >= 2) & write (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR ! ! Second accuracy test. ! end if A = 0.0E0 B = 4.0E0*ATAN(1.0E0) ERR = TOL/100.0E0 call GAUS8 (FQD2, A, B, ERR, ANS, IERR) COR = (EXP(B)-1.0E0)/101.0E0 if ( ABS(ANS-COR) <= TOL .and. IERR == 1 ) then if ( kprint >= 3) & write (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR else ipass = 0 if ( kprint >= 2) & write (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR ! ! Test error returns. ! end if call XGETF (KONTRL) if ( kprint <= 2 ) then call XSETF (0) else call XSETF (1) end if ! FATAL = .FALSE. ! ! Test with a discontinuous integrand and a tight error tolerance. ! if ( kprint >= 3) write (LUN,FMT=9030) A = 0.0E0 B = 1.0E0 COR = 2.0E0 ERR = 100.0E0*R1MACH(4) REQ = ERR ! ! See if test passed. ! call GAUS8 (FQD1, A, B, ERR, ANS, IERR) if ( IERR == 2 ) then if ( kprint >= 3) & write (LUN,FMT=9040) 'PASSED', REQ, ANS, IERR, ERR, COR else if ( kprint >= 2) & write (LUN,FMT=9040) 'PASSED', REQ, ANS, IERR, ERR, COR ipass = 0 FATAL = .TRUE. ! ! Test GAUS8 with A and B nearly equal. ! end if A = 2.0E0 B = A*(1.0E0+R1MACH(4)) COR = 0.0E0 ! ERR = TOL ! ! Check to see if test passed. ! call GAUS8 (FQD1, A, B, ERR, ANS, IERR) if ( IERR == -1 .and. ANS == 0.0E0 ) then if ( kprint >= 3) write (LUN,9050) 'PASSED' else ipass = 0 FATAL = .TRUE. if ( kprint >= 2) write (LUN,9050) 'FAILED' ! end if call XSETF (KONTRL) if ( FATAL ) then if ( kprint >= 2 ) then write (LUN, 9060) end if else if ( kprint >= 3 ) then write (LUN, 9070) end if ! end if if ( ipass == 1 .and. KPRINT >= 3) write (LUN,FMT=9080) if ( ipass == 0 .and. KPRINT >= 2) write (LUN,FMT=9090) ! return 9000 FORMAT ('1' / ' GAUS8 Quick Check') 9010 FORMAT (/ ' Accuracy test of GAUS8 ', A / & ' A = ', F10.5, ' B = ', F10.5 / & ' Computed result = ', E14.7, ' Exact result = ', & E14.7 / & ' Tolerance = ', E14.7, ' IERR = ', I2 /) 9030 FORMAT (/ ' Test error returns' / & ' 2 error messages expected' /) 9040 FORMAT (' Test of GAUS8 ', A / & ' REQ =', E10.2, 5X, 'ANS =', E20.13, 5X, 'IERR =', I2, & 5X, 'should be 2' / & ' ERR =', E10.2, ' CORRECT =' ,E20.13 /) 9050 FORMAT (' Test of A and B nearly equal ', A) 9060 FORMAT (/ ' At least one incorrect argument test FAILED') 9070 FORMAT (/ ' All incorrect argument tests PASSED') 9080 FORMAT (/,' ***************GAUS8 PASSED ALL TESTS***************') 9090 FORMAT (/,' ***************GAUS8 FAILED SOME TESTS**************') end !! QN79QX !***PURPOSE Quick check for QNC79. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (QN79QX-S, DQN79Q-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED FQD1, FQD2, QNC79, R1MACH, 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) ! 910501 Added PURPOSE and TYPE records. (WRB) ! 910708 Minor modifications in use of KPRINT. (WRB) ! 920213 Code restructured to test QNC79 for all values of KPRINT, ! second accuracy test added and testing of error returns ! revised. (WRB) !***END PROLOGUE QN79QX ! .. Scalar Arguments .. subroutine QN79QX (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN integer IERR, NFCT REAL A, ANS, B, COR, ERR, REQ, TOL ! .. External Functions .. LOGICAL FATAL REAL FQD1, FQD2, R1MACH ! .. External Subroutines .. EXTERNAL FQD1, FQD2, R1MACH ! .. Intrinsic Functions .. EXTERNAL QNC79, XGETF, XSETF !***FIRST EXECUTABLE STATEMENT QN79QX INTRINSIC ABS, MAX, SQRT ! ! Initialize variables for testing. ! if ( kprint >= 2) write (LUN,FMT=9000) TOL = SQRT(R1MACH(4)) ! ! First accuracy test. ! ipass = 1 A = 1.0E0 B = 4.0E0 ERR = TOL/100.0E0 call QNC79 (FQD1, A, B, ERR, ANS, IERR, NFCT) COR = 2.0E0 if ( ABS(ANS-COR) <= TOL .and. IERR == 1 ) then if ( kprint >= 3) & write (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR, NFCT else ipass = 0 if ( kprint >= 2) & write (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR, NFCT ! ! Second accuracy test. ! end if A = 0.0E0 B = 4.0E0*ATAN(1.0E0) ERR = TOL/10.0E0 call QNC79 (FQD2, A, B, ERR, ANS, IERR, NFCT) COR = (EXP(B)-1.0E0)/101.0E0 if ( ABS(ANS-COR) <= TOL .and. IERR == 1 ) then if ( kprint >= 3) & write (LUN, 9010) 'PASSED', A, B, ANS, COR, ERR, IERR, NFCT else ipass = 0 if ( kprint >= 2) & write (LUN, 9010) 'FAILED', A, B, ANS, COR, ERR, IERR, NFCT ! ! Test error returns. ! end if call XGETF (KONTRL) if ( kprint <= 2 ) then call XSETF (0) else call XSETF (1) end if ! FATAL = .FALSE. ! ! Test with a discontinuous integrand and a tight error tolerance. ! if ( kprint >= 3) write (LUN,FMT=9030) A = 0.0E0 B = 1.0E0 COR = 2.0E0 ERR = 100.0E0*R1MACH(4) REQ = ERR ! ! See if test passed. ! call QNC79 (FQD1, A, B, ERR, ANS, IERR, NFCT) if ( IERR == 2 ) then if ( kprint >= 3) & write (LUN,FMT=9040) 'PASSED', REQ, ANS, IERR, ERR, COR else if ( kprint >= 2) & write (LUN,FMT=9040) 'FAILED', REQ, ANS, IERR, ERR, COR ipass = 0 FATAL = .TRUE. ! ! Test QNC79 with A and B nearly equal. ! end if A = 2.0E0 B = A*(1.0E0+R1MACH(4)) COR = 0.0E0 ! ERR = TOL ! ! Check to see if test passed. ! call QNC79 (FQD1, A, B, ERR, ANS, IERR, NFCT) if ( IERR == -1 .and. ANS == 0.0E0 ) then if ( kprint >= 3) write (LUN,9050) 'PASSED' else ipass = 0 FATAL = .TRUE. if ( kprint >= 2) write (LUN,9050) 'FAILED' ! end if call XSETF (KONTRL) if ( FATAL ) then if ( kprint >= 2 ) then write (LUN, 9060) end if else if ( kprint >= 3 ) then write (LUN, 9070) end if ! end if if ( ipass == 1 .and. KPRINT >= 3) write (LUN,FMT=9080) if ( ipass == 0 .and. KPRINT >= 2) write (LUN,FMT=9090) ! return 9000 FORMAT ('1' / ' QNC79 Quick Check') 9010 FORMAT (/ ' Accuracy test of QNC79 ', A / & ' A = ', F10.5, ' B = ', F10.5 / & ' Computed result = ', E14.7, ' Exact result = ', & E14.7 / & ' Tolerance = ', E14.7, ' IERR = ', I2, & ' Number of function evals = ', I5 /) 9030 FORMAT (/ ' Test error returns' / & ' 2 error messages expected' /) 9040 FORMAT (' Test of QNC79 ', A / & ' REQ =', E10.2, 5X, 'ANS =', E20.13, 5X, 'IERR =', I2, & 5X, 'should be 2' / & ' ERR =', E10.2, ' CORRECT =' ,E20.13 /) 9050 FORMAT (' Test of A and B nearly equal ', A) 9060 FORMAT (/ ' At least one incorrect argument test FAILED') 9070 FORMAT (/ ' All incorrect argument tests PASSED') 9080 FORMAT (/' ***************QNC79 PASSED ALL TESTS****************') 9090 FORMAT (/' ***************QNC79 FAILED SOME TESTS***************') end !! QXABM !***SUBSIDIARY !***PURPOSE Test the DEPAC routine DEABM. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (QXABM-S, QXDABM-D) !***KEYWORDS QUICK CHECK !***AUTHOR Chow, Jeff, (LANL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call QXABM (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: ! ! DEABM is tested by solving the equations of motion of a body ! moving in a plane about a spherical earth, namely ! (D/DT)(D/DT)X = -G*X/R**3 ! (D/DT)(D/DT)Y = -G*Y/R**3 ! where G = 1, R = SQRT(X**2 + Y**2) and ! X(0) = 1 ! (D/DT)X(0) = 0 ! Y(0) = 0 ! (D/DT)Y(0) = 1. ! !***ROUTINES CALLED DEABM, FDEQC, R1MACH !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900415 Code extensively revised. (WRB) !***END PROLOGUE QXABM ! ! Declare arguments. ! subroutine QXABM (LUN, KPRINT, IPASS) ! ! Declare local variables. ! integer LUN, KPRINT, IPASS integer IDID, INFO(15), IPAR, IWORK(51), N, LIW, LRW REAL ABSERR, R, R1MACH, RELERR, RELTOL, RPAR, RWORK(214), T, TOUT, & U(4) !***FIRST EXECUTABLE STATEMENT QXABM EXTERNAL FDEQC ! ! Initialize problem. ! if ( kprint >= 2) write (LUN, 9000) N = 4 LRW = 214 LIW = 51 T = 0.0E0 TOUT = 8.0E0*ATAN(1.0E0) U(1) = 1.0E0 U(2) = 0.0E0 U(3) = 0.0E0 U(4) = 1.0E0 ipass = 1 RELTOL = SQRT(R1MACH(4)) RELERR = 0.1E0*RELTOL ABSERR = RELERR**1.5E0 INFO(1) = 0 INFO(2) = 0 INFO(3) = 1 INFO(4) = 0 ! if ( kprint > 2) write (LUN, 9010) RELERR, ABSERR, T, (1.0E0) 100 call DEABM (FDEQC, N, T, U, TOUT, INFO, RELERR, ABSERR, & IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR) R = SQRT(U(1)*U(1)+U(2)*U(2)) if ( ABS(R-1.0E0) > RELTOL) ipass = 0 if ( kprint > 2) write (LUN, 9020) T, R INFO(1) = 1 ! ! Finish up. ! if ( IDID == 1) GO TO 100 if ( IDID < 1) ipass = 0 if ( kprint > 1 .and. IDID < 1) write (LUN, 9030) IDID if ( kprint > 1 .and. ipass == 1) write (LUN, 9040) if ( KPRINT >= 1 .and. ipass == 0) write (LUN, 9050) ! ! FORMATs. ! return 9000 FORMAT ('1'/' ------------ DEABM QUICK CHECK OUTPUT', & ' ------------') 9010 FORMAT (/ ' RELERR = ', E16.8, ' ABSERR =', E16.8 / & 12X, 'T', 19X, 'R' / 2E20.8) 9020 FORMAT (2E20.8) 9030 FORMAT (1X, 'ERROR RETURN FROM DEABM. IDID = ', I3) 9040 FORMAT (/ ' ------------ DEABM PASSED TESTS ------------') 9050 FORMAT (/ ' ************ DEABM FAILED TESTS ************') end !! QXBDF !***PURPOSE Test the DEPAC routine DEBDF. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (QXBDF-S, QXDBDF-D) !***KEYWORDS QUICK CHECK !***AUTHOR Chow, Jeff, (LANL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call QXBDF (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: ! ! DEBDF is tested by solving the equations of motion of a body ! moving in a plane about a spherical earth, namely ! (D/DT)(D/DT)X = -G*X/R**3 ! (D/DT)(D/DT)Y = -G*Y/R**3 ! where G = 1, R = SQRT(X**2 + Y**2) and ! X(0) = 1 ! (D/DT)X(0) = 0 ! Y(0) = 0 ! (D/DT)Y(0) = 1. ! !***ROUTINES CALLED DEBDF, FDEQC, JAC, R1MACH !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900415 Code extensively revised. (WRB) !***END PROLOGUE QXBDF ! ! Declare arguments. ! subroutine QXBDF (LUN, KPRINT, IPASS) ! ! Declare local variables. ! integer LUN, KPRINT, IPASS integer IDID, INFO(15), IPAR, IWORK(60), N, LIW, LRW REAL ABSERR, R, R1MACH, RELERR, RELTOL, RPAR, RWORK(306), T, TOUT, & U(4) !***FIRST EXECUTABLE STATEMENT QXBDF EXTERNAL FDEQC, JAC ! ! Initialize problem. ! if ( kprint >= 2) write (LUN, 9000) N = 4 LRW = 306 LIW = 60 T = 0.0E0 TOUT = 8.0E0*ATAN(1.0E0) U(1) = 1.0E0 U(2) = 0.0E0 U(3) = 0.0E0 U(4) = 1.0E0 ipass = 1 RELTOL = SQRT(R1MACH(4)) RELERR = 0.001E0*RELTOL ABSERR = RELERR**1.5E0 INFO(1) = 0 INFO(2) = 0 INFO(3) = 1 INFO(4) = 0 INFO(5) = 1 INFO(6) = 0 ! if ( kprint > 2) write (LUN, 9010) RELERR, ABSERR, T, (1.0E0) 100 call DEBDF (FDEQC, N, T, U, TOUT, INFO, RELERR, ABSERR, & IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC) R = SQRT(U(1)*U(1)+U(2)*U(2)) if ( ABS(R-1.0E0) > RELTOL) ipass = 0 if ( kprint > 2) write (LUN, 9020) T, R INFO(1) = 1 ! ! Finish up. ! if ( IDID == 1) GO TO 100 if ( IDID < 1) ipass = 0 if ( kprint > 1 .and. IDID < 1) write (LUN, 9030) IDID if ( kprint > 1 .and. ipass == 1) write (LUN, 9040) if ( KPRINT >= 1 .and. ipass == 0) write (LUN, 9050) ! ! FORMATs. ! return 9000 FORMAT ('1'/' ------------ DEBDF QUICK CHECK OUTPUT', & ' ------------') 9010 FORMAT (/ ' RELERR = ', E16.8, ' ABSERR =', E16.8 / & 12X, 'T', 19X, 'R' / 2E20.8) 9020 FORMAT (2E20.8) 9030 FORMAT (1X, 'ERROR RETURN FROM DEBDF. IDID = ', I3) 9040 FORMAT (/ ' ------------ DEBDF PASSED TESTS ------------') 9050 FORMAT (/ ' ************ DEBDF FAILED TESTS ************') end subroutine QXBLKT (LUN, KPRINT, IPASS) ! !! QXBLKT !***PURPOSE !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * ! * F I S H P A K * ! * * ! * * ! * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * ! * * ! * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * ! * * ! * (VERSION 3 , JUNE 1979) * ! * * ! * BY * ! * * ! * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * ! * * ! * OF * ! * * ! * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * ! * * ! * BOULDER, COLORADO (80307) U.S.A. * ! * * ! * WHICH IS SPONSORED BY * ! * * ! * THE NATIONAL SCIENCE FOUNDATION * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! PROGRAM TO ILLUSTRATE THE USE OF BLKTRI ! !***ROUTINES CALLED BLKTRI !***REVISION HISTORY (YYMMDD) ! 800103 DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Added PASS/FAIL message and cleaned up FORMATs. (RWC) !***END PROLOGUE QXBLKT dimension Y(75,105), AM(75), BM(75), CM(75), AN(105), BN(105), & CN(105), W(1952), S(75), T(105) ERMAX=1.E-3 IFLG = 0 NP = 1 N = 63 MP = 1 M = 50 ! ! GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING THE ! COEFFICIENTS AND THE ARRAY Y. ! IDIMY = 75 DELTAS = 1.0E0/(M+1) DO I=1,M S(I) = I * DELTAS end do DELTAT = 1.0E0/(N+1) DO J=1,N T(J) = J*DELTAT end do ! ! COMPUTE THE COEFFICIENTS AM, BM AND CM CORRESPONDING TO THE S DIRECTION. ! HDS = DELTAS/2. TDS = DELTAS+DELTAS DO I=1,M TEMP1 = 1./(S(I)*TDS) TEMP2 = 1./((S(I)-HDS)*TDS) TEMP3 = 1./((S(I)+HDS)*TDS) AM(I) = TEMP1*TEMP2 CM(I) = TEMP1*TEMP3 BM(I) = -(AM(I)+CM(I)) end do ! ! COMPUTE THE COEFFICIENTS AN, BN AND CN CORRESPONDING TO THE T DIRECTION. ! HDT = DELTAT/2. TDT = DELTAT+DELTAT DO J=1,N TEMP1 = 1./(T(J)*TDT) TEMP2 = 1./((T(J)-HDT)*TDT) TEMP3 = 1./((T(J)+HDT)*TDT) AN(J) = TEMP1*TEMP2 CN(J) = TEMP1*TEMP3 BN(J) = -(AN(J)+CN(J)) end do ! ! COMPUTE RIGHT SIDE OF EQUATION ! DO J=1,N DO I=1,M Y(I,J) = 3.75*S(I)*T(J)*(S(I)**4.+T(J)**4.) end do end do ! ! INCLUDE NONHOMOGENEOUS BOUNDARY INTO RIGHT SIDE. NOTE THAT THE ! CORNER AT J=N,I=M INCLUDES CONTRIBUTIONS FROM BOTH BOUNDARIES. ! DO J=1,N Y(M,J) = Y(M,J)-CM(M)*T(J)**5. end do DO I=1,M Y(I,N) = Y(I,N)-CN(N)*S(I)**5. end do 109 continue call BLKTRI (IFLG,NP,N,AN,BN,CN,MP,M,AM,BM,CM,IDIMY,Y,IERROR,W) IFLG = IFLG+1 ! ! COMPUTE DISCRETIZATION ERROR ! if ( IFLG-1) 109,109,110 110 ERR = 0. DO J=1,N DO I=1,M Z = ABS(Y(I,J)-(S(I)*T(J))**5.) if ( Z > ERR) ERR = Z end do end do ipass = 1 if ( ERR > ERMAX) ipass = 0 if ( kprint == 0) RETURN if ( KPRINT >= 2 .OR. ipass == 0 ) then write (LUN,1001) IERROR,ERR,INT(W(1)) if ( ipass == 1 ) then write (LUN, 1002) else write (LUN, 1003) end if end if ! return 1001 FORMAT ('1',20X,'SUBROUTINE BLKTRI EXAMPLE'/// & 10X,'THE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS'// & 32X,'IERROR = 0'/ & 18X,'DISCRETIZATION ERROR = 1.6478E-05'/ & 12X,'REQUIRED LENGTH OF W ARRAY = 823'// & 10X,'THE OUTPUT FROM YOUR COMPUTER IS'// & 32X,'IERROR =',I2/ & 18X,'DISCRETIZATION ERROR =',1PE12.5/ & 12X,'REQUIRED LENGTH OF W ARRAY =', I4) 1002 FORMAT (60X,'PASS'/) 1003 FORMAT (60X,'FAIL'/) end !! QXBVSP !***PURPOSE Quick check for BVSUP. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (QXBVSP-S, QXDBVS-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED BVSUP, PASS !***COMMON BLOCKS SAVEX !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901014 Made editorial changes and added correct result to ! output. (RWC) ! 910708 Minor modifications in use of KPRINT. (WRB) !***END PROLOGUE QXBVSP subroutine QXBVSP ( LUN, KPRINT, IPASS ) integer ITMP(9), IWORK(100) dimension Y(4,15),XPTS(15),A(2,4),ALPHA(2),B(2,4),BETA(2), & YANS(2,15),WORK(1000) CHARACTER*4 MSG COMMON /SAVEX/ XSAVE, TERM DATA YANS(1,1),YANS(2,1),YANS(1,2),YANS(2,2), & YANS(1,3),YANS(2,3),YANS(1,4),YANS(2,4), & YANS(1,5),YANS(2,5),YANS(1,6),YANS(2,6), & YANS(1,7),YANS(2,7),YANS(1,8),YANS(2,8), & YANS(1,9),YANS(2,9),YANS(1,10),YANS(2,10), & YANS(1,11),YANS(2,11),YANS(1,12),YANS(2,12), & YANS(1,13),YANS(2,13),YANS(1,14),YANS(2,14), & YANS(1,15),YANS(2,15)/ & 5.000000000E+00,-6.888880126E-01, 8.609248635E+00, & -1.083092311E+00, 1.674923836E+01,-2.072210073E+00, & 3.351098494E+01,-4.479263780E+00, 6.601103894E+01, & -8.909222513E+00, 8.579580988E+01,-1.098742758E+01, & 1.106536877E+02,-1.402469444E+01, 1.421228220E+02, & -1.742236546E+01, 1.803383474E+02,-2.086465851E+01, & 2.017054332E+02,-1.990879843E+01, 2.051622475E+02, & -1.324886978E+01, 2.059197452E+02, 1.051529813E+01, & 1.972191446E+02, 9.320592785E+01, 1.556894846E+02, & 3.801682434E+02, 1.818989404E-12, 1.379853993E+03/ DATA XPTS(1),XPTS(2),XPTS(3),XPTS(4),XPTS(5), & XPTS(6),XPTS(7),XPTS(8),XPTS(9),XPTS(10), & XPTS(11),XPTS(12),XPTS(13),XPTS(14),XPTS(15)/ & 60.,55.,50.,45.,40.,38.,36.,34.,32.,31.,30.8,30.6, & !***FIRST EXECUTABLE STATEMENT QXBVSP 30.4,30.2,30./ if ( KPRINT >= 2 ) then write (LUN,800) write (LUN,810) ! ! INITIALIZE VARIABLES FOR TEST PROBLEM. ! end if DO 10 I = 1, 9 ITMP(I) = 0 ! 10 continue TOL = 1.0E-03 XSAVE = 0. NROWY = 4 NCOMP = 2 NXPTS = 15 A(1,1) = 1.0 A(1,2) = 0.0 NROWA = 2 ALPHA(1) = 5.0 NIC = 1 B(1,1) = 1.0 B(1,2) = 0.0 NROWB = 2 BETA(1) = 0.0 NFC = 1 IGOFX = 1 RE = 1.0E-05 AE = 1.0E-05 NDW = 1000 NDIW = 100 NEQIVP = 0 ! ipass = 1 DO 20 I = 1, 15 IWORK(I) = 0 ! 20 continue call BVSUP(Y,NROWY,NCOMP,XPTS,NXPTS,A,NROWA,ALPHA,NIC,B,NROWB, & ! ! IF IFLAG = 0, WE HAVE A SUCCESSFUL SOLUTION; OTHERWISE, SKIP ! THE ARGUMENT CHECKING AND GO TO THE END. ! BETA,NFC,IGOFX,RE,AE,IFLAG,WORK,NDW,IWORK,NDIW,NEQIVP) if ( IFLAG /= 0 ) then ipass = 0 if ( kprint > 1) write (LUN,820) IFLAG GO TO 170 ! ! CHECK THE ACCURACY OF THE SOLUTION. ! end if NUMORT = IWORK(1) DO 50 J = 1, NXPTS DO 40 L = 1, 2 ABSER = ABS(YANS(L,J)-Y(L,J)) RELER = ABSER/ABS(YANS(L,J)) if ( RELER > TOL .and. ABSER > TOL) ipass = 0 40 continue ! ! CHECK FOR SUPPRESSION OF PRINTING. ! 50 continue ! if ( kprint == 0 .OR. (KPRINT == 1 .and. ipass == 1)) GO TO 190 if ( kprint /= 1 .OR. ipass /= 0 ) then if ( KPRINT >= 3 .OR. ipass == 0 ) then write (LUN,830) write (LUN,840) NUMORT write (LUN,850) (WORK(J),J = 1, NUMORT) write (LUN,860) DO 60 J = 1, NXPTS MSG = 'PASS' ABSER = ABS(YANS(1,J)-Y(1,J)) RELER = ABSER/ABS(YANS(1,J)) if ( RELER > TOL .and. ABSER > TOL) MSG = 'FAIL' ABSER = ABS(YANS(2,J)-Y(2,J)) RELER = ABSER/ABS(YANS(2,J)) if ( RELER > TOL .and. ABSER > TOL) MSG = 'FAIL' write (LUN,870) XPTS(J),Y(1,J),Y(2,J),YANS(1,J), & YANS(2,J),MSG 60 continue end if ! ! SEND MESSAGE INDICATING PASSAGE OR FAILURE OF TESTS. ! end if ! ! ERROR MESSAGE TESTS. ! call PASS (LUN, 1, IPASS) if ( kprint == 1) GO TO 190 KONT = 1 ! ! NROWY LESS THAN NCOMP ! write (LUN,880) KOUNT = 1 NROWY = 1 150 DO 160 I = 1, 15 IWORK(I) = 0 160 continue call BVSUP(Y,NROWY,NCOMP,XPTS,NXPTS,A,NROWA,ALPHA,NIC,B,NROWB, & BETA,NFC,IGOFX,RE,AE,IFLAG,WORK,NDW,IWORK,NDIW,NEQIVP) ! GO TO (80,90,100,110,120,130,140), KOUNT 80 write (LUN,900) IFLAG if ( IFLAG == -2) ITMP(KONT) = 1 ! ! IGOFX NOT EQUAL TO 0 OR 1 ! KONT = KONT + 1 KOUNT = 2 NROWY = 2 IGOFX = 3 ! GO TO 150 90 write (LUN,900) IFLAG if ( IFLAG == -2) ITMP(KONT) = 1 ! ! RE OR AE NEGATIVE ! KONT = KONT + 1 KOUNT = 3 IGOFX = 1 RE = -1. AE = -2. ! GO TO 150 100 write (LUN,900) IFLAG if ( IFLAG == -2) ITMP(KONT) = 1 ! ! NROWA LESS THAN NIC ! KONT = KONT + 1 KOUNT = 4 RE = 1.0E-05 AE = 1.0E-05 ! NROWA = 0 110 write (LUN,900) IFLAG if ( IFLAG == -2) ITMP(KONT) = 1 ! NROWB LESS THAN NFC KONT = KONT + 1 KOUNT = 5 NROWA = 2 ! NROWB = 0 120 write (LUN,900) IFLAG if ( IFLAG == -2) ITMP(KONT) = 1 ! STORAGE ALLOCATION IS INSUFFICIENT KONT = KONT + 1 KOUNT = 6 NROWB = 2 NDIW = 17 ! GO TO 150 130 write (LUN,910) IFLAG if ( IFLAG == -1) ITMP(KONT) = 1 ! INCORRECT ORDERING OF XPTS KONT = KONT + 1 KOUNT = 7 NDIW = 100 SVE = XPTS(1) XPTS(1) = XPTS(4) XPTS(4) = SVE ! GO TO 150 140 write (LUN,900) IFLAG ! ! SEE IF IFLAG TESTS PASSED ! if ( IFLAG == -2) ITMP(KONT) = 1 170 IPSS = 1 DO 180 I = 1, KONT IPSS = IPSS*ITMP(I) ! 180 continue ! ! SEE IF ALL TESTS PASSED. ! call PASS (LUN, 2, IPSS) ! ipass = IPASS*IPSS 190 if ( ipass == 1 .and. kprint > 1) write (LUN,980) if ( ipass == 0 .and. kprint /= 0) write (LUN,990) ! return 800 FORMAT ('1') 810 FORMAT (/' BVSUP QUICK CHECK') 820 FORMAT (10X,'IFLAG =',I2) 830 FORMAT (/' ACCURACY TEST') 840 FORMAT (/' NUMBER OF ORTHONORMALIZATIONS =',I3) 850 FORMAT (/' ORTHONORMALIZATION POINTS ARE'/(1X,4F10.2)) 860 FORMAT (//20X,'CALCULATION',30X,'TRUE SOLUTION'/ & 2X,'X',14X,'Y',17X,'Y-PRIME',15X,'Y',17X,'Y-PRIME'/) 870 FORMAT (F5.1,4E20.7,5X,A) 880 FORMAT (/' (7) TESTS OF IFLAG VALUES') 900 FORMAT (/' IFLAG SHOULD BE -2, IFLAG =',I3) 910 FORMAT (/' IFLAG SHOULD BE -1, IFLAG =',I3) 980 FORMAT (/' ****************BVSUP PASSED ALL TESTS***************') 990 FORMAT (/' ****************BVSUP FAILED SOME TESTS**************') end !! QXCRT !***PURPOSE !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * ! * F I S H P A K * ! * * ! * * ! * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * ! * * ! * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * ! * * ! * (VERSION 3 , JUNE 1979) * ! * * ! * BY * ! * * ! * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * ! * * ! * OF * ! * * ! * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * ! * * ! * BOULDER, COLORADO (80307) U.S.A. * ! * * ! * WHICH IS SPONSORED BY * ! * * ! * THE NATIONAL SCIENCE FOUNDATION * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! PROGRAM TO ILLUSTRATE THE USE OF SUBROUTINE HWSCRT TO SOLVE ! THE EQUATION ! ! (D/DX)(DU/DX) + (D/DY)(DU/DY) - 4*U ! ! = (2 - (4 + PI**2/4)*X**2)*COS((Y+1)*PI/2) ! ! WITH THE BOUNDARY CONDITIONS ! ON THE RECTANGLE 0 < X < 2, -1 < Y < 3 WITH THE ! ! U(0,Y) = 0 ! -1 <= Y <= 3 ! (DU/DX)(2,Y) = 4*COS((Y+1)*PI/2) ! ! AND WITH U PERIODIC IN Y. ! THE X-INTERVAL WILL BE DIVIDED INTO 40 PANELS AND THE ! Y-INTERVAL WILL BE DIVIDED INTO 80 PANELS. ! !***ROUTINES CALLED HWSCRT, PIMACH !***REVISION HISTORY (YYMMDD) ! 800103 DATE WRITTEN ! 890718 Changed computation of PI to use PIMACH. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Added PASS/FAIL message and cleaned up FORMATs. (RWC) !***END PROLOGUE QXCRT subroutine QXCRT (LUN, KPRINT, IPASS) !***FIRST EXECUTABLE STATEMENT QXCRT ! ! FROM DIMENSION STATEMENT WE GET VALUE OF IDIMF. ALSO NOTE THAT W ! IS DIMENSIONED 6*(N+1) + 8*(M+1). ! dimension F(45,82), BDB(81), W(1200), X(41), Y(81) IDIMF = 45 ERMAX=1.E-3 A = 0. B = 2. M = 40 MBDCND = 2 C = -1. D = 3. N = 80 NBDCND = 0 ! ! AUXILIARY QUANTITIES. ! ELMBDA = -4. PI = PIMACH(DUM) PIBY2 = PI/2. PISQ = PI**2 MP1 = M+1 ! ! GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING ! BOUNDARY DATA AND THE RIGHT SIDE OF THE HELMHOLTZ EQUATION. ! NP1 = N+1 DO 101 I=1,MP1 X(I) = (I-1)/20.0E0 101 continue DO 102 J=1,NP1 Y(J) = -1.0E0+(J-1)/20.0E0 ! ! GENERATE BOUNDARY DATA. ! 102 continue DO 103 J=1,NP1 BDB(J) = 4.*COS((Y(J)+1.)*PIBY2) ! ! BDA, BDC, AND BDD ARE DUMMY VARIABLES. ! 103 continue DO 104 J=1,NP1 F(1,J) = 0. ! ! GENERATE RIGHT SIDE OF EQUATION. ! 104 continue DO 106 I=2,MP1 DO 105 J=1,NP1 F(I,J) = (2.-(4.+PISQ/4.)*X(I)**2)*COS((Y(J)+1.)*PIBY2) 105 continue 106 continue call HWSCRT(A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,ELMBDA,F, & ! ! COMPUTE DISCRETIZATION ERROR. THE EXACT SOLUTION IS ! U(X,Y) = X**2*COS((Y+1)*PIBY2) ! IDIMF,PERTRB,IERROR,W) ERR = 0. DO 108 I=1,MP1 DO 107 J=1,NP1 Z = ABS(F(I,J)-X(I)**2*COS((Y(J)+1.)*PIBY2)) if ( Z > ERR) ERR = Z 107 continue ! 108 continue ipass = 1 if ( ERR > ERMAX) ipass = 0 if ( kprint == 0) RETURN if ( KPRINT >= 2 .OR. ipass == 0 ) then write (LUN,1001) IERROR,ERR,INT(W(1)) if ( ipass == 1 ) then write (LUN, 1002) else write (LUN, 1003) end if end if ! return 1001 FORMAT ('1',20X,'SUBROUTINE HWSCRT EXAMPLE'/// & 10X,'THE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS'// & 32X,'IERROR = 0'/ & 18X,'DISCRETIZATION ERROR = 5.36508E-04'/ & 12X,'REQUIRED LENGTH OF W ARRAY = 880'// & 10X,'THE OUTPUT FROM YOUR COMPUTER IS'// & 32X,'IERROR =',I2/ & 18X,'DISCRETIZATION ERROR =',1PE12.5/ & 12X,'REQUIRED LENGTH OF W ARRAY =',I4) 1002 FORMAT (60X,'PASS'/) 1003 FORMAT (60X,'FAIL'/) end !! QXCSP !***PURPOSE !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * ! * F I S H P A K * ! * * ! * * ! * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * ! * * ! * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * ! * * ! * (VERSION 3 , JUNE 1979) * ! * * ! * BY * ! * * ! * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * ! * * ! * OF * ! * * ! * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * ! * * ! * BOULDER, COLORADO (80307) U.S.A. * ! * * ! * WHICH IS SPONSORED BY * ! * * ! * THE NATIONAL SCIENCE FOUNDATION * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! PROGRAM TO ILLUSTRATE THE USE OF HWSCSP ! !***ROUTINES CALLED HWSCSP, PIMACH !***REVISION HISTORY (YYMMDD) ! 800103 DATE WRITTEN ! 890718 Changed computation of PI to use PIMACH. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Added PASS/FAIL message and cleaned up FORMATs. (RWC) !***END PROLOGUE QXCSP subroutine QXCSP (LUN, KPRINT, IPASS) !***FIRST EXECUTABLE STATEMENT QXCSP ! ! THE VALUE OF IDIMF IS THE FIRST DIMENSION OF F. SINCE M=36, N=32, ! L=N THEREFORE K=5 AND W IS DIMENSIONED 2*(L+1)*(K-1) + 6*(M+N) ! + max ( 4*N,6*M) + 14 = 902. ! dimension F(48,33), BDTF(33), W(1200), R(33), THETA(48) ERMAX=1.E-3 PI = PIMACH(DUM) INTL = 0 TS = 0. TF = PI/2. M = 36 MBDCND = 6 RS = 0. RF = 1. N = 32 NBDCND = 5 ELMBDA = 0. ! ! GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING THE ! BOUNDARY DATA AND THE RIGHT SIDE OF THE EQUATION. ! IDIMF = 48 MP1 = M+1 DTHETA = TF/M DO 101 I=1,MP1 THETA(I) = (I-1)*DTHETA 101 continue NP1 = N+1 DR = 1.0E0/N DO 102 J=1,NP1 R(J) = (J-1)*DR ! ! GENERATE NORMAL DERIVATIVE DATA AT EQUATOR ! 102 continue DO 103 J=1,NP1 BDTF(J) = 0. ! ! COMPUTE BOUNDARY DATA ON THE SURFACE OF THE SPHERE ! 103 continue DO 104 I=1,MP1 F(I,N+1) = COS(THETA(I))**4 ! ! COMPUTE RIGHT SIDE OF EQUATION ! 104 continue DO 106 I=1,MP1 CI4 = 12.0E0*COS(THETA(I))**2 DO 105 J=1,N F(I,J) = CI4*R(J)**2 105 continue 106 continue call HWSCSP (INTL,TS,TF,M,MBDCND,BDTS,BDTF,RS,RF,N,NBDCND,BDRS, & ! ! COMPUTE DISCRETIZATION ERROR ! BDRF,ELMBDA,F,IDIMF,PERTRB,IERROR,W) ERR = 0. DO 108 I=1,MP1 CI4 = COS(THETA(I))**4 DO 107 J=1,N Z = ABS(F(I,J)-CI4*R(J)**4) if ( Z > ERR) ERR = Z 107 continue 108 continue ipass = 1 if ( ERR > ERMAX) ipass = 0 if ( kprint /= 0 ) then if ( KPRINT >= 2 .OR. ipass == 0 ) then write (LUN,1001) IERROR,ERR,INT(W(1)) if ( ipass == 1 ) then write (LUN, 1003) else write (LUN, 1004) end if end if ! ! THE FOLLOWING PROGRAM ILLUSTRATES THE USE OF HWSCSP TO SOLVE ! A THREE DIMENSIONAL PROBLEM WHICH HAS LONGITUDINAL DEPENDENCE ! end if MBDCND = 2 NBDCND = 1 DPHI = PI/72. ! ! COMPUTE BOUNDARY DATA ON THE SURFACE OF THE SPHERE ! ELMBDA = -2.0E0*(1.0E0-COS(DPHI))/DPHI**2 DO 109 I=1,MP1 F(I,N+1) = SIN(THETA(I)) ! ! COMPUTE RIGHT SIDE OF THE EQUATION ! 109 continue DO 111 J=1,N DO 110 I=1,MP1 F(I,J) = 0. 110 continue 111 continue call HWSCSP (INTL,TS,TF,M,MBDCND,BDTS,BDTF,RS,RF,N,NBDCND,BDRS, & ! ! COMPUTE DISCRETIZATION ERROR (FOURIER COEFFICIENTS) ! BDRF,ELMBDA,F,IDIMF,PERTRB,IERROR,W) ERR = 0. DO 113 I=1,MP1 SI = SIN(THETA(I)) DO 112 J=1,NP1 Z = ABS(F(I,J)-R(J)*SI) if ( Z > ERR) ERR = Z 112 continue 113 continue if ( ERR > ERMAX) ipass = 0 if ( kprint == 0) RETURN if ( KPRINT >= 2 .OR. ipass == 0 ) then write (LUN,1002) IERROR,ERR,INT(W(1)) if ( ipass == 1 ) then write (LUN, 1003) else write (LUN, 1004) end if end if return 1001 FORMAT ('1',20X,'SUBROUTINE HWSCSP EXAMPLE 1'/// & 10X,'THE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS'// & 32X,'IERROR = 0'/ & 18X,'DISCRETIZATION ERROR = 7.99842E-04'/ & 12X,'REQUIRED LENGTH OF W ARRAY = 775'// & 10X,'THE OUTPUT FROM YOUR COMPUTER IS'// & 32X,'IERROR =',I2/ & 18X,'DISCRETIZATION ERROR =',1PE12.5/ & 12X,'REQUIRED LENGTH OF W ARRAY =',I4) 1002 FORMAT ('1',20X,'SUBROUTINE HWSCSP EXAMPLE 2'/// & 10X,'THE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS'// & 32X,'IERROR = 0'/ & 18X,'DISCRETIZATION ERROR = 5.86824E-05'/ & 12X,'REQUIRED LENGTH OF W ARRAY = 775'// & 10X,'THE OUTPUT FROM YOUR COMPUTER IS'// & 32X,'IERROR =',I2/ & 18X,'DISCRETIZATION ERROR =',1PE12.5/ & 12X,'REQUIRED LENGTH OF W ARRAY =',I4) 1003 FORMAT (60X,'PASS'/) 1004 FORMAT (60X,'FAIL'/) end !! QXCYL !***PURPOSE !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * ! * F I S H P A K * ! * * ! * * ! * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * ! * * ! * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * ! * * ! * (VERSION 3 , JUNE 1979) * ! * * ! * BY * ! * * ! * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * ! * * ! * OF * ! * * ! * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * ! * * ! * BOULDER, COLORADO (80307) U.S.A. * ! * * ! * WHICH IS SPONSORED BY * ! * * ! * THE NATIONAL SCIENCE FOUNDATION * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! PROGRAM TO ILLUSTRATE THE USE OF SUBROUTINE HWSCYL TO SOLVE ! THE EQUATION ! ! (1/R)(D/DR)(R*(DU/DR)) + (D/DZ)(DU/DZ) ! ! = (2*R*Z)**2*(4*Z**2 + 3*R**2) ! ! ON THE RECTANGLE 0 < R < 1, 0 < Z < 1 WITH THE ! BOUNDARY CONDITIONS ! ! U(0,Z) UNSPECIFIED ! 0 <= Z <= 1 ! (DU/DR)(1,Z) = 4*Z**4 ! ! AND ! ! (DU/DZ)(R,0) = 0 ! 0 <= R <= 1 ! (DU/DZ)(R,1) = 4*R**4 . ! ! THE R-INTERVAL WILL BE DIVIDED INTO 50 PANELS AND THE ! Z-INTERVAL WILL BE DIVIDED INTO 100 PANELS. ! !***ROUTINES CALLED HWSCYL !***REVISION HISTORY (YYMMDD) ! 800103 DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Added PASS/FAIL message and cleaned up FORMATs. (RWC) ! 930415 Test modified to use a 64 by 128 grid. (WRB) !***END PROLOGUE QXCYL subroutine QXCYL (LUN, KPRINT, IPASS) dimension F(65,129), BDA(129), BDB(129), BDC(65), BDD(65), & !***FIRST EXECUTABLE STATEMENT QXCYL W(1400), R(65), Z(129) ! ! FROM DIMENSION STATEMENT WE GET VALUE OF IDIMF. ! if ( kprint >= 2) write (LUN, 1000) IDIMF = 65 ERMAX = 1.0E-3 A = 0.0 B = 1.0 M = 64 MBDCND = 6 C = 0.0 D = 1.0 N = 128 NBDCND = 3 ! ! AUXILIARY QUANTITIES. ! ELMBDA = 0.0 MP1 = M+1 ! ! GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING ! BOUNDARY DATA AND THE RIGHT SIDE OF THE POISSON EQUATION. ! NP1 = N+1 DO 101 I=1,MP1 R(I) = (I-1)/64.0E0 101 continue DO 102 J=1,NP1 Z(J) = (J-1)/128.0E0 ! ! GENERATE BOUNDARY DATA. ! 102 continue DO 103 J=1,NP1 BDB(J) = 4.0*Z(J)**4 103 continue DO 104 I=1,MP1 BDC(I) = 0.0 BDD(I) = 4.0*R(I)**4 ! ! BDA IS A DUMMY VARIABLE. ! ! GENERATE RIGHT SIDE OF EQUATION. ! 104 continue DO 106 I=1,MP1 DO 105 J=1,NP1 F(I,J) = 4.0*R(I)**2*Z(J)**2*(4.0*Z(J)**2+3.0*R(I)**2) 105 continue 106 continue call HWSCYL (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,ELMBDA,F, & ! ! COMPUTE DISCRETIZATION ERROR BY MINIMIZING OVER ALL A THE FUNCTION ! NORM(F(I,J) - A - U(R(I),Z(J))). THE EXACT SOLUTION IS ! U(R,Z) = (R*Z)**4 + ARBITRARY CONSTANT. ! IDIMF,PERTRB,IERROR,W) X = 0.0 DO 108 I=1,MP1 DO 107 J=1,NP1 X = X+F(I,J)-(R(I)*Z(J))**4 107 continue 108 continue X = X/(NP1*MP1) DO 110 I=1,MP1 DO 109 J=1,NP1 F(I,J) = F(I,J)-X 109 continue 110 continue ERR = 0.0 DO 112 I=1,MP1 DO 111 J=1,NP1 X = ABS(F(I,J)-(R(I)*Z(J))**4) if ( X > ERR) ERR = X 111 continue 112 continue ipass = 1 if ( ERR > ERMAX) ipass = 0 if ( KPRINT >= 3 .OR. (KPRINT>=2 .and. ipass == 0)) & ! ! Print PASS/FAIL message. ! write (LUN,1001) IERROR,PERTRB,ERR,INT(W(1)) if ( ipass == 1 .and. KPRINT >= 2) write (LUN, 1002) if ( ipass == 0 .and. KPRINT >= 1) write (LUN, 1003) return 1000 FORMAT ('1', 20X, 'SUBROUTINE HWSCYL EXAMPLE' //) 1001 FORMAT (10X, 'THE OUTPUT FROM YOUR COMPUTER IS' // & 32X, 'IERROR =', I2 / & 32X, 'PERTRB =', E12.5 / & 18X, 'DISCRETIZATION ERROR =', 1PE12.5 / & 12X, 'REQUIRED LENGTH OF W ARRAY = ', I4) 1002 FORMAT (25X, 'HWSCYL TEST PASSED' /) 1003 FORMAT (25X, 'HWSCYL TEST FAILED' /) end !! QXDABM !***PURPOSE Test the DEPAC routine DDEABM. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (QXABM-S, QXDABM-D) !***KEYWORDS QUICK CHECK !***AUTHOR Chow, Jeff, (LANL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call QXDABM (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: ! ! DDEABM is tested by solving the equations of motion of a body ! moving in a plane about a spherical earth, namely ! (D/DT)(D/DT)X = -G*X/R**3 ! (D/DT)(D/DT)Y = -G*Y/R**3 ! where G = 1, R = SQRT(X**2 + Y**2) and ! X(0) = 1 ! (D/DT)X(0) = 0 ! Y(0) = 0 ! (D/DT)Y(0) = 1. ! !***ROUTINES CALLED d1mach, DDEABM, DFDEQC !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900415 Code extensively revised. (WRB) !***END PROLOGUE QXDABM ! ! Declare arguments. ! subroutine QXDABM (LUN, KPRINT, IPASS) ! ! Declare local variables. ! integer LUN, KPRINT, IPASS integer IDID, INFO(15), IPAR, IWORK(51), N, LIW, LRW, NSTEP double precision ABSERR, d1mach, R, RELERR, RELTOL, RPAR, & RWORK(214), T, TOUT, U(4) !***FIRST EXECUTABLE STATEMENT QXDABM EXTERNAL DFDEQC ! ! Initialize problem. ! if ( kprint >= 2) write (LUN, 9000) N = 4 LRW = 214 LIW = 51 T = 0.0D0 TOUT = 8.0D0*ATAN(1.0D0) U(1) = 1.0D0 U(2) = 0.0D0 U(3) = 0.0D0 U(4) = 1.0D0 ipass = 1 NSTEP = 0 RELTOL = SQRT(d1mach(4)) RELERR = 0.1D0*RELTOL ABSERR = RELERR**1.5D0 INFO(1) = 0 INFO(2) = 0 INFO(3) = 1 INFO(4) = 0 if ( kprint > 2) write (LUN, 9010) RELERR, ABSERR, T, (1.0D0) 100 call DDEABM (DFDEQC, N, T, U, TOUT, INFO, RELERR, ABSERR, & IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR) R = SQRT(U(1)*U(1)+U(2)*U(2)) if ( ABS(R-1.0D0) > RELTOL) ipass = 0 if ( kprint > 2) write (LUN, 9020) T, R INFO(1) = 1 ! ! For the double precision version, we allow the integrator to take ! up to 2000 steps before we declare failure. ! if ( IDID == 1) GO TO 100 if ( IDID == -1 ) then NSTEP = NSTEP + 500 if ( NSTEP < 2000) GOTO 100 ! ! Finish up. ! end if if ( IDID < 1) ipass = 0 if ( kprint > 1 .and. IDID < 1) write (LUN, 9030) IDID if ( kprint > 1 .and. ipass == 1) write (LUN, 9040) if ( KPRINT >= 1 .and. ipass == 0) write (LUN, 9050) ! ! FORMATs. ! return 9000 FORMAT ('1'/' ------------ DDEABM QUICK CHECK OUTPUT', & ' ------------') 9010 FORMAT (/ ' RELERR = ', D16.8, ' ABSERR =', D16.8 / & 12X, 'T', 19X, 'R' / 2D20.8) 9020 FORMAT (2D20.8) 9030 FORMAT (1X, 'ERROR RETURN FROM DDEABM. IDID = ', I3) 9040 FORMAT (/ ' ------------ DDEABM PASSED TESTS ------------') 9050 FORMAT (/ ' ************ DDEABM FAILED TESTS ************') end !! QXDBDF !***PURPOSE Test the DEPAC routine DDEBDF. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (QXBDF-S, QXDBDF-D) !***KEYWORDS QUICK CHECK !***AUTHOR Chow, Jeff, (LANL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call QXDBDF (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: ! ! DDEBDF is tested by solving the equations of motion of a body ! moving in a plane about a spherical earth, namely ! (D/DT)(D/DT)X = -G*X/R**3 ! (D/DT)(D/DT)Y = -G*Y/R**3 ! where G = 1, R = SQRT(X**2 + Y**2) and ! X(0) = 1 ! (D/DT)X(0) = 0 ! Y(0) = 0 ! (D/DT)Y(0) = 1. ! !***ROUTINES CALLED d1mach, DDEBDF, DFDEQC, DJAC !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900415 Code extensively revised. (WRB) !***END PROLOGUE QXDBDF ! ! Declare arguments. ! subroutine QXDBDF (LUN, KPRINT, IPASS) ! ! Declare local variables. ! integer LUN, KPRINT, IPASS integer IDID, INFO(15), IPAR, IWORK(60), N, LIW, LRW, NSTEP double precision ABSERR, d1mach, R, RELTOL, RELERR, RPAR, & RWORK(306), T, TOUT, U(4) !***FIRST EXECUTABLE STATEMENT QXDBDF EXTERNAL DFDEQC, DJAC ! ! Initialize problem. ! if ( kprint >= 2) write (LUN, 9000) N = 4 LRW = 306 LIW = 60 T = 0.0D0 TOUT = 8.0D0*ATAN(1.0D0) U(1) = 1.0D0 U(2) = 0.0D0 U(3) = 0.0D0 U(4) = 1.0D0 ipass = 1 NSTEP = 0 RELTOL = max ( SQRT(d1mach(4)),1.D-9) RELERR = max ( 0.0001D0*RELTOL,1.D-12) ABSERR = RELERR**1.5D0 INFO(1) = 0 INFO(2) = 0 INFO(3) = 1 INFO(4) = 0 INFO(5) = 1 INFO(6) = 0 ! if ( kprint > 2) write (LUN, 9010) RELERR, ABSERR, T, (1.0D0) 100 call DDEBDF (DFDEQC, N, T, U, TOUT, INFO, RELERR, ABSERR, & IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, DJAC) R = SQRT(U(1)*U(1)+U(2)*U(2)) if ( ABS(R-1.0D0) > RELTOL) ipass = 0 if ( kprint > 2) write (LUN, 9020) T, R INFO(1) = 1 ! ! For the double precision version, we allow the integrator to take ! up to 2000 steps before we declare failure. ! if ( IDID == 1) GO TO 100 if ( IDID == -1 ) then NSTEP = NSTEP + 500 if ( NSTEP < 2000) GOTO 100 ! ! Finish up. ! end if if ( IDID < 1) ipass = 0 if ( kprint > 1 .and. IDID < 1) write (LUN, 9030) IDID if ( kprint > 1 .and. ipass == 1) write (LUN, 9040) if ( KPRINT >= 1 .and. ipass == 0) write (LUN, 9050) ! ! FORMATs. ! return 9000 FORMAT ('1'/' ------------ DDEBDF QUICK CHECK OUTPUT', & ' ------------') 9010 FORMAT (/ ' RELERR = ', D16.8, ' ABSERR =', D16.8 / & 12X, 'T', 19X, 'R' / 2D20.8) 9020 FORMAT (2D20.8) 9030 FORMAT (1X, 'ERROR RETURN FROM DDEBDF. IDID = ', I3) 9040 FORMAT (/ ' ------------ DDEBDF PASSED TESTS ------------') 9050 FORMAT (/ ' ************ DDEBDF FAILED TESTS ************') end !! QXDBVS !***PURPOSE Quick check for DBVSUP. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (QXBVSP-S, QXDBVS-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED DBVSUP, PASS !***COMMON BLOCKS DSAVEX !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901014 Made editorial changes and added correct result to ! output. (RWC) ! 910708 Minor modifications in use of KPRINT. (WRB) !***END PROLOGUE QXDBVS subroutine QXDBVS (LUN, KPRINT, IPASS) integer ITMP(9), IWORK(100) double precision WORK(1000),AE,RE,XSAVE,SVE,TERM,TOL double precision Y(4,15),XPTS(15),A(2,4),ALPHA(2),B(2,4),BETA(2), & YANS(2,15),RELER,ABSER CHARACTER*4 MSG COMMON /DSAVEX/ XSAVE, TERM DATA YANS(1,1),YANS(2,1),YANS(1,2),YANS(2,2), & YANS(1,3),YANS(2,3),YANS(1,4),YANS(2,4), & YANS(1,5),YANS(2,5),YANS(1,6),YANS(2,6), & YANS(1,7),YANS(2,7),YANS(1,8),YANS(2,8), & YANS(1,9),YANS(2,9),YANS(1,10),YANS(2,10), & YANS(1,11),YANS(2,11),YANS(1,12),YANS(2,12), & YANS(1,13),YANS(2,13),YANS(1,14),YANS(2,14), & YANS(1,15),YANS(2,15)/ & 5.000000000D+00,-6.888880126D-01, 8.609248635D+00, & -1.083092311D+00, 1.674923836D+01,-2.072210073D+00, & 3.351098494D+01,-4.479263780D+00, 6.601103894D+01, & -8.909222513D+00, 8.579580988D+01,-1.098742758D+01, & 1.106536877D+02,-1.402469444D+01, 1.421228220D+02, & -1.742236546D+01, 1.803383474D+02,-2.086465851D+01, & 2.017054332D+02,-1.990879843D+01, 2.051622475D+02, & -1.324886978D+01, 2.059197452D+02, 1.051529813D+01, & 1.972191446D+02, 9.320592785D+01, 1.556894846D+02, & 3.801682434D+02, 1.818989404D-12, 1.379853993D+03/ DATA XPTS(1),XPTS(2),XPTS(3),XPTS(4),XPTS(5), & XPTS(6),XPTS(7),XPTS(8),XPTS(9),XPTS(10), & XPTS(11),XPTS(12),XPTS(13),XPTS(14),XPTS(15)/ & 60.0D+00,55.0D+00,50.0D+00,45.0D+00,40.0D+00,38.0D+00, & 36.0D+00,34.0D+00,32.0D+00,31.0D+00,30.8D+00,30.6D+00, & !***FIRST EXECUTABLE STATEMENT QXDBVS 30.4D+00,30.2D+00,30.0D+00/ if ( KPRINT >= 2 ) then write (LUN,800) write (LUN,810) ! ! INITIALIZE VARIABLES FOR TEST PROBLEM. ! end if DO 10 I = 1, 9 ITMP(I) = 0 10 continue TOL = 1.0D-03 XSAVE = 0.0D+00 NROWY = 4 NCOMP = 2 NXPTS = 15 A(1,1) = 1.0D+00 A(1,2) = 0.0D+00 NROWA = 2 ALPHA(1) = 5.0D+00 NIC = 1 B(1,1) = 1.0D+00 B(1,2) = 0.0D+00 NROWB = 2 BETA(1) = 0.0D+00 NFC = 1 IGOFX = 1 RE = 1.0D-05 AE = 1.0D-05 NDW = 1000 NDIW = 100 NEQIVP = 0 ipass = 1 DO 20 I = 1, 15 IWORK(I) = 0 20 continue call DBVSUP(Y,NROWY,NCOMP,XPTS,NXPTS,A,NROWA,ALPHA,NIC,B,NROWB, & ! ! IF IFLAG = 0, WE HAVE A SUCCESSFUL SOLUTION; OTHERWISE, SKIP ! THE ARGUMENT CHECKING AND GO TO THE END. ! BETA,NFC,IGOFX,RE,AE,IFLAG,WORK,NDW,IWORK,NDIW,NEQIVP) if ( IFLAG /= 0 ) then ipass = 0 if ( kprint > 1) write (LUN,820) IFLAG GO TO 170 ! ! CHECK THE ACCURACY OF THE SOLUTION. ! end if NUMORT = IWORK(1) DO 50 J = 1, NXPTS DO 40 L = 1, 2 ABSER = ABS(YANS(L,J)-Y(L,J)) RELER = ABSER/ABS(YANS(L,J)) if ( RELER > TOL .and. ABSER > TOL) ipass = 0 40 continue ! ! CHECK FOR SUPPRESSION OF PRINTING. ! 50 continue if ( kprint == 0 .OR. (KPRINT == 1 .and. ipass == 1)) GO TO 190 if ( kprint /= 1 .OR. ipass /= 0 ) then if ( KPRINT >= 3 .OR. ipass == 0 ) then write (LUN,830) write (LUN,840) NUMORT write (LUN,850) (WORK(J),J = 1, NUMORT) write (LUN,860) DO 60 J = 1, NXPTS MSG = 'PASS' ABSER = ABS(YANS(1,J)-Y(1,J)) RELER = ABSER/ABS(YANS(1,J)) if ( RELER > TOL .and. ABSER > TOL) MSG = 'FAIL' ABSER = ABS(YANS(2,J)-Y(2,J)) RELER = ABSER/ABS(YANS(2,J)) if ( RELER > TOL .and. ABSER > TOL) MSG = 'FAIL' write (LUN,870) XPTS(J),Y(1,J),Y(2,J),YANS(1,J), & YANS(2,J),MSG 60 continue end if ! ! SEND MESSAGE INDICATING PASSAGE OR FAILURE OF TESTS. ! end if ! ! ERROR MESSAGE TESTS. ! call PASS (LUN, 1, IPASS) if ( kprint == 1) GO TO 190 KONT = 1 ! ! NROWY LESS THAN NCOMP ! write (LUN,880) KOUNT = 1 NROWY = 1 150 DO 160 I = 1, 15 IWORK(I) = 0 160 continue call DBVSUP(Y,NROWY,NCOMP,XPTS,NXPTS,A,NROWA,ALPHA,NIC,B,NROWB, & BETA,NFC,IGOFX,RE,AE,IFLAG,WORK,NDW,IWORK,NDIW,NEQIVP) ! GO TO (80,90,100,110,120,130,140), KOUNT 80 write (LUN,900) IFLAG if ( IFLAG == -2) ITMP(KONT) = 1 ! ! IGOFX NOT EQUAL TO 0 OR 1 ! KONT = KONT + 1 KOUNT = 2 NROWY = 2 IGOFX = 3 ! GO TO 150 90 write (LUN,900) IFLAG if ( IFLAG == -2) ITMP(KONT) = 1 ! ! RE OR AE NEGATIVE ! KONT = KONT + 1 KOUNT = 3 IGOFX = 1 RE = -1.0D+00 AE = -2.0D+00 ! GO TO 150 100 write (LUN,900) IFLAG if ( IFLAG == -2) ITMP(KONT) = 1 ! ! NROWA LESS THAN NIC ! KONT = KONT + 1 KOUNT = 4 RE = 1.0D-05 AE = 1.0D-05 ! NROWA = 0 110 write (LUN,900) IFLAG if ( IFLAG == -2) ITMP(KONT) = 1 ! NROWB LESS THAN NFC KONT = KONT + 1 KOUNT = 5 NROWA = 2 ! NROWB = 0 120 write (LUN,900) IFLAG if ( IFLAG == -2) ITMP(KONT) = 1 ! STORAGE ALLOCATION IS INSUFFICIENT KONT = KONT + 1 KOUNT = 6 NROWB = 2 NDIW = 17 ! GO TO 150 130 write (LUN,910) IFLAG if ( IFLAG == -1) ITMP(KONT) = 1 ! INCORRECT ORDERING OF XPTS KONT = KONT + 1 KOUNT = 7 NDIW = 100 SVE = XPTS(1) XPTS(1) = XPTS(4) XPTS(4) = SVE ! GO TO 150 140 write (LUN,900) IFLAG ! ! SEE IF IFLAG TESTS PASSED ! if ( IFLAG == -2) ITMP(KONT) = 1 170 IPSS = 1 DO 180 I = 1, KONT IPSS = IPSS*ITMP(I) ! 180 continue ! ! SEE IF ALL TESTS PASSED. ! call PASS (LUN, 2, IPSS) ! ipass = IPASS*IPSS 190 if ( ipass == 1 .and. kprint > 1) write (LUN,980) if ( ipass == 0 .and. kprint /= 0) write (LUN,990) ! return 800 FORMAT ('1') 810 FORMAT (/' DBVSUP QUICK CHECK') 820 FORMAT (10X,'IFLAG =',I2) 830 FORMAT (/' ACCURACY TEST') 840 FORMAT (/' NUMBER OF ORTHONORMALIZATIONS =',I3) 850 FORMAT (/' ORTHONORMALIZATION POINTS ARE'/(1X,4F10.2)) 860 FORMAT (//20X,'CALCULATION',30X,'TRUE SOLUTION'/ & 2X,'X',14X,'Y',17X,'Y-PRIME',15X,'Y',17X,'Y-PRIME'/) 870 FORMAT (F5.1,4E20.7,5X,A) 880 FORMAT (/' (7) TESTS OF IFLAG VALUES') 900 FORMAT (/' IFLAG SHOULD BE -2, IFLAG =',I3) 910 FORMAT (/' IFLAG SHOULD BE -1, IFLAG =',I3) 980 FORMAT (/' ***************DBVSUP PASSED ALL TESTS***************') 990 FORMAT (/' ***************DBVSUP FAILED SOME TESTS**************') end !! QXDRKF !***PURPOSE Test the DEPAC routine DDERKF. !***LIBRARY SLATEC !***TYPE DOUBLE PRECISION (QXRKF-S, QXDRKF-D) !***KEYWORDS QUICK CHECK !***AUTHOR Chow, Jeff, (LANL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call QXDRKF (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: ! ! DDERKF is tested by solving the equations of motion of a body ! moving in a plane about a spherical earth, namely ! (D/DT)(D/DT)X = -G*X/R**3 ! (D/DT)(D/DT)Y = -G*Y/R**3 ! where G = 1, R = SQRT(X**2 + Y**2) and ! X(0) = 1 ! (D/DT)X(0) = 0 ! Y(0) = 0 ! (D/DT)Y(0) = 1. ! !***ROUTINES CALLED d1mach, DDERKF, DFDEQC !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900415 Code extensively revised. (WRB) !***END PROLOGUE QXDRKF ! ! Declare arguments. ! subroutine QXDRKF (LUN, KPRINT, IPASS) ! ! Declare local variables. ! integer LUN, KPRINT, IPASS integer IDID, INFO(15), IPAR, IWORK(34), N, LIW, LRW, NSTEP double precision ABSERR, d1mach, R, RELERR, RELTOL, RPAR, & RWORK(61), T, TOUT, U(4) !***FIRST EXECUTABLE STATEMENT QXDRKF EXTERNAL DFDEQC ! ! Initialize problem. ! if ( kprint >= 2) write (LUN, 9000) N = 4 LRW = 61 LIW = 34 T = 0.0D0 TOUT = 8.0D0*ATAN(1.0D0) U(1) = 1.0D0 U(2) = 0.0D0 U(3) = 0.0D0 U(4) = 1.0D0 ipass = 1 NSTEP = 0 RELTOL = max ( SQRT(d1mach(4)),1.D-10) RELERR = max ( .1D0*RELTOL,1.D-12) ABSERR = RELERR**1.5D0 INFO(1) = 0 INFO(2) = 0 INFO(3) = 1 INFO(4) = 0 ! if ( kprint > 2) write (LUN, 9010) RELERR, ABSERR, T, (1.0D0) 100 call DDERKF (DFDEQC, N, T, U, TOUT, INFO, RELERR, ABSERR, & IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR) R = SQRT(U(1)*U(1)+U(2)*U(2)) if ( ABS(R-1.0D0) > RELTOL) ipass = 0 if ( kprint > 2) write (LUN, 9020) T, R INFO(1) = 1 ! ! For the double precision version, we allow the integrator to take ! up to 2000 steps before we declare failure. ! if ( IDID == 1) GO TO 100 if ( IDID == -1 ) then NSTEP = NSTEP + 500 if ( NSTEP < 2000) GOTO 100 ! ! Finish up. ! end if if ( IDID < 1) ipass = 0 if ( kprint > 1 .and. IDID < 1) write (LUN, 9030) IDID if ( kprint > 1 .and. ipass == 1) write (LUN, 9040) if ( KPRINT >= 1 .and. ipass == 0) write (LUN, 9050) ! ! FORMATs. ! return 9000 FORMAT ('1'/' ------------ DDERKF QUICK CHECK OUTPUT', & ' ------------') 9010 FORMAT (/ ' RELERR = ', D16.8, ' ABSERR =', D16.8 / & 12X, 'T', 19X, 'R' / 2D20.8) 9020 FORMAT (2D20.8) 9030 FORMAT (1X, 'ERROR RETURN FROM DDERKF. IDID = ', I3) 9040 FORMAT (/ ' ------------ DDERKF PASSED TESTS ------------') 9050 FORMAT (/ ' ************ DDERKF FAILED TESTS ************') end !! QXGBUN !***PURPOSE !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * ! * F I S H P A K * ! * * ! * * ! * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * ! * * ! * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * ! * * ! * (VERSION 3 , JUNE 1979) * ! * * ! * BY * ! * * ! * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * ! * * ! * OF * ! * * ! * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * ! * * ! * BOULDER, COLORADO (80307) U.S.A. * ! * * ! * WHICH IS SPONSORED BY * ! * * ! * THE NATIONAL SCIENCE FOUNDATION * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! PROGRAM TO ILLUSTRATE THE USE OF SUBROUTINE GENBUN ! !***ROUTINES CALLED GENBUN, PIMACH !***REVISION HISTORY (YYMMDD) ! 750701 DATE WRITTEN ! 890718 Changed computation of PI to use PIMACH. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 891009 Removed unreferenced variable. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Added PASS/FAIL message and cleaned up FORMATs. (RWC) !***END PROLOGUE QXGBUN subroutine QXGBUN (LUN, KPRINT, IPASS) !***FIRST EXECUTABLE STATEMENT QXGBUN ! ! FROM DIMENSION STATEMENT WE GET VALUE OF IDIMY. ALSO NOTE THAT ! W(.) IS DIMENSIONED 6*N + 5*M. ! dimension F(25,130), A(20), B(20), C(20), W(1200), X(20), Y(120) ERMAX=1.E-2 IDIMY = 25 MPEROD = 1 M = 20 DELTAX = 1.0E0/M NPEROD = 0 N = 120 PI = PIMACH(DUM) ! ! GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING ! COEFFICIENTS AND RIGHT SIDE OF EQUATION. ! DELTAY = 2.0E0*PI/N DO 100 I=1,M X(I) = (I-1)*DELTAX 100 continue DO 105 J=1,N Y(J) = -PI + (J-1)*DELTAY ! ! GENERATE COEFFICIENTS. ! 105 continue S = (DELTAY/DELTAX)**2 T = S*DELTAX A(1) = 0. B(1) = -2.0E0*S C(1) = 2.0E0*S DO 110 I=2,M A(I) = (1.+X(I))**2*S + (1.+X(I))*T C(I) = (1.+X(I))**2*S - (1.+X(I))*T B(I) = -2.0E0*(1.0E0+X(I))**2*S 110 continue ! ! GENERATE RIGHT SIDE OF EQUATION FOR I = 1 SHOWING INTRODUCTION OF ! BOUNDARY DATA. ! C(M) = 0. DYSQ = DELTAY**2 DO 115 J=1,N F(1,J) = DYSQ*(11. + 8./DELTAX)*SIN(Y(J)) ! ! GENERATE RIGHT SIDE. ! 115 continue MM1 = M-1 DO 125 I=2,MM1 DO 120 J=1,N F(I,J) = DYSQ*3.*(1.+X(I))**4*SIN(Y(J)) 120 continue ! ! GENERATE RIGHT SIDE FOR I = M SHOWING INTRODUCTION OF ! BOUNDARY DATA. ! 125 continue DO 130 J=1,N F(M,J) = DYSQ*(3.*(1.+X(M))**4 - 16.*((1.+X(M))/DELTAX)**2 & + 16.*(1.+X(M))/DELTAX)*SIN(Y(J)) 130 continue ! ! COMPUTE DISCRETIZATION ERROR. THE EXACT SOLUTION IS ! U(X,Y) = (1+X)**4*SIN(Y) ! call GENBUN(NPEROD,N,MPEROD,M,A,B,C,IDIMY,F,IERROR,W) ERR = 0. DO 140 I=1,M DO 135 J=1,N Z = ABS(F(I,J)-(1.+X(I))**4*SIN(Y(J))) if ( Z > ERR) ERR = Z 135 continue ! 140 continue ipass = 1 if ( ERR > ERMAX) ipass = 0 if ( kprint == 0) RETURN if ( KPRINT >= 2 .OR. ipass == 0 ) then write (LUN,1001) IERROR, ERR, INT(W(1)) if ( ipass == 1 ) then write (LUN, 1002) else write (LUN, 1003) end if end if ! return 1001 FORMAT ('1',20X,'SUBROUTINE GENBUN EXAMPLE'/// & 10X,'THE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS'// & 32X,'IERROR = 0'/ & 18X,'DISCRETIZATION ERROR = 7.94113E-03'/ & 12X,'REQUIRED LENGTH OF W ARRAY = 740'// & 10X,'THE OUTPUT FROM YOUR COMPUTER IS'// & 32X,'IERROR =',I2/ & 18X,'DISCRETIZATION ERROR =',1PE12.5/ & 12X,'REQUIRED LENGTH OF W ARRAY =',I4) 1002 FORMAT (60X,'PASS'/) 1003 FORMAT (60X,'FAIL'/) end !! QXPLR !***PURPOSE !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * ! * F I S H P A K * ! * * ! * * ! * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * ! * * ! * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * ! * * ! * (VERSION 3 , JUNE 1979) * ! * * ! * BY * ! * * ! * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * ! * * ! * OF * ! * * ! * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * ! * * ! * BOULDER, COLORADO (80307) U.S.A. * ! * * ! * WHICH IS SPONSORED BY * ! * * ! * THE NATIONAL SCIENCE FOUNDATION * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! PROGRAM TO ILLUSTRATE THE USE OF SUBROUTINE HWSPLR TO SOLVE ! THE EQUATION ! ! (1/R)(D/DR)(R*(DU/DR)) + (1/R**2)(D/DTHETA)(DU/DTHETA) = 16*R**2 ! ! ON THE QUARTER-DISK 0 < R < 1, 0 < THETA < PI/2 WITH ! WITH THE BOUNDARY CONDITIONS ! ! U(1,THETA) = 1 - COS(4*THETA), 0 <= THETA <= 1 ! ! AND ! ! (DU/DTHETA)(R,0) = (DU/DTHETA)(R,PI/2) = 0, 0 <= R <= 1. ! ! (NOTE THAT THE SOLUTION U IS UNSPECIFIED AT R = 0.) ! THE R-INTERVAL WILL BE DIVIDED INTO 50 PANELS AND THE ! THETA-INTERVAL WILL BE DIVIDED INTO 48 PANELS. ! !***ROUTINES CALLED HWSPLR, PIMACH !***REVISION HISTORY (YYMMDD) ! 800103 DATE WRITTEN ! 890718 Changed computation of PI to use PIMACH. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Added PASS/FAIL message and cleaned up FORMATs. (RWC) !***END PROLOGUE QXPLR subroutine QXPLR (LUN, KPRINT, IPASS) !***FIRST EXECUTABLE STATEMENT QXPLR ! ! FROM DIMENSION STATEMENT WE GET VALUE OF IDIMF. ALSO NOTE THAT W ! IS DIMENSIONED 6*(N+1) + 8*(M+1). ! dimension F(100,50), BDC(51), BDD(51), W(1200), R(51), THETA(49) IDIMF = 100 ERMAX=1.E-3 A = 0. B = 1. M = 50 MBDCND = 5 C = 0. PI = PIMACH(DUM) D = PI/2. N = 48 NBDCND = 3 ! ! AUXILIARY QUANTITIES. ! ELMBDA = 0. MP1 = M+1 ! ! GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING ! BOUNDARY DATA AND THE RIGHT SIDE OF THE POISSON EQUATION. ! NP1 = N+1 DO 101 I=1,MP1 R(I) = (I-1)/50.0E0 101 continue DO 102 J=1,NP1 THETA(J) = (J-1)*PI/96.0E0 ! ! GENERATE BOUNDARY DATA. ! 102 continue DO 103 I=1,MP1 BDC(I) = 0. BDD(I) = 0. ! ! BDA AND BDB ARE DUMMY VARIABLES. ! 103 continue DO 104 J=1,NP1 F(MP1,J) = 1.-COS(4.*THETA(J)) ! ! GENERATE RIGHT SIDE OF EQUATION. ! 104 continue DO 106 I=1,M DO 105 J=1,NP1 F(I,J) = 16.*R(I)**2 105 continue 106 continue call HWSPLR(A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,ELMBDA,F, & ! ! COMPUTE DISCRETIZATION ERROR. THE EXACT SOLUTION IS ! U(R,THETA) = R**4*(1 - COS(4*THETA)) ! IDIMF,PERTRB,IERROR,W) ERR = 0. DO 108 I=1,MP1 DO 107 J=1,NP1 Z = ABS(F(I,J)-R(I)**4*(1.-COS(4.*THETA(J)))) if ( Z > ERR) ERR = Z 107 continue ! 108 continue ipass = 1 if ( ERR > ERMAX) ipass = 0 if ( kprint == 0) RETURN if ( KPRINT >= 2 .OR. ipass == 0 ) then write (LUN,1001) IERROR,ERR,INT(W(1)) if ( ipass == 1 ) then write (LUN, 1002) else write (LUN, 1003) end if end if ! return 1001 FORMAT ('1',20X,'SUBROUTINE HWSPLR EXAMPLE'/// & 10X,'THE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS'// & 32X,'IERROR = 0'/ & 18X,'DISCRETIZATION ERROR = 6.19134E-04'/ & 12X,'REQUIRED LENGTH OF W ARRAY = 882'// & 10X,'THE OUTPUT FROM YOUR COMPUTER IS'// & 32X,'IERROR =',I2/ & 18X,'DISCRETIZATION ERROR =',1PE12.5/ & 12X,'REQUIRED LENGTH OF W ARRAY =',I4) 1002 FORMAT (60X,'PASS'/) 1003 FORMAT (60X,'FAIL'/) end !! QXRKF !***PURPOSE Test the DEPAC routine DERKF. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (QXRKF-S, QXDRKF-D) !***KEYWORDS QUICK CHECK !***AUTHOR Chow, Jeff, (LANL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call QXRKF (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: ! ! DERKF is tested by solving the equations of motion of a body ! moving in a plane about a spherical earth, namely ! (D/DT)(D/DT)X = -G*X/R**3 ! (D/DT)(D/DT)Y = -G*Y/R**3 ! where G = 1, R = SQRT(X**2 + Y**2) and ! X(0) = 1 ! (D/DT)X(0) = 0 ! Y(0) = 0 ! (D/DT)Y(0) = 1. ! !***ROUTINES CALLED DERKF, FDEQC, R1MACH !***REVISION HISTORY (YYMMDD) ! 810801 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900415 Code extensively revised. (WRB) !***END PROLOGUE QXRKF ! ! Declare arguments. ! subroutine QXRKF (LUN, KPRINT, IPASS) ! ! Declare local variables. ! integer LUN, KPRINT, IPASS integer IDID, INFO(15), IPAR, IWORK(34), N, LIW, LRW REAL ABSERR, R, R1MACH, RELERR, RELTOL, RPAR, RWORK(61), T, TOUT, & U(4) !***FIRST EXECUTABLE STATEMENT QXRKF EXTERNAL FDEQC ! ! Initialize problem. ! if ( kprint >= 2) write (LUN, 9000) N = 4 LRW = 61 LIW = 34 T = 0.0E0 TOUT = 8.0E0*ATAN(1.0E0) U(1) = 1.0E0 U(2) = 0.0E0 U(3) = 0.0E0 U(4) = 1.0E0 ipass = 1 RELTOL = SQRT(R1MACH(4)) RELERR = 0.1E0*RELTOL ABSERR = RELERR**1.5E0 INFO(1) = 0 INFO(2) = 0 INFO(3) = 1 INFO(4) = 0 ! if ( kprint > 2) write (LUN, 9010) RELERR, ABSERR, T, (1.0E0) 100 call DERKF (FDEQC, N, T, U, TOUT, INFO, RELERR, ABSERR, & IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR) R = SQRT(U(1)*U(1)+U(2)*U(2)) if ( ABS(R-1.0E0) > RELTOL) ipass = 0 if ( kprint > 2) write (LUN, 9020) T, R INFO(1) = 1 ! ! Finish up. ! if ( IDID == 1) GO TO 100 if ( IDID < 1) ipass = 0 if ( kprint > 1 .and. IDID < 1) write (LUN, 9030) IDID if ( kprint > 1 .and. ipass == 1) write (LUN, 9040) if ( KPRINT >= 1 .and. ipass == 0) write (LUN, 9050) ! ! FORMATs. ! return 9000 FORMAT ('1'/' ------------ DERKF QUICK CHECK OUTPUT', & ' ------------') 9010 FORMAT (/ ' RELERR = ', E16.8, ' ABSERR =', E16.8 / & 12X, 'T', 19X, 'R' / 2E20.8) 9020 FORMAT (2E20.8) 9030 FORMAT (1X, 'ERROR RETURN FROM DERKF. IDID = ', I3) 9040 FORMAT (/ ' ------------ DERKF PASSED TESTS ------------') 9050 FORMAT (/ ' ************ DERKF FAILED TESTS ************') end !! QXSSP !***PURPOSE !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! * * ! * F I S H P A K * ! * * ! * * ! * A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF * ! * * ! * SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS * ! * * ! * (VERSION 3 , JUNE 1979) * ! * * ! * BY * ! * * ! * JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET * ! * * ! * OF * ! * * ! * THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH * ! * * ! * BOULDER, COLORADO (80307) U.S.A. * ! * * ! * WHICH IS SPONSORED BY * ! * * ! * THE NATIONAL SCIENCE FOUNDATION * ! * * ! * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ! ! ! ! PROGRAM TO ILLUSTRATE THE USE OF HWSSSP ! !***ROUTINES CALLED HWSSSP, PIMACH !***REVISION HISTORY (YYMMDD) ! 800103 DATE WRITTEN ! 890718 Changed computation of PI to use PIMACH. (WRB) ! 890911 Removed unnecessary intrinsics. (WRB) ! 890911 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Added PASS/FAIL message and cleaned up FORMATs. (RWC) !***END PROLOGUE QXSSP subroutine QXSSP (LUN, KPRINT, IPASS) !***FIRST EXECUTABLE STATEMENT QXSSP ! ! THE VALUE OF IDIMF IS THE FIRST DIMENSION OF F. W IS ! DIMENSIONED 11*(M+1)+6*(N+1)=647 SINCE M=18 AND N=72. ! dimension F(19,73), BDTF(73), SINT(19), SINP(73), W(1200) PI = PIMACH(DUM) ERMAX=5.E-3 TS = 0.0 TF = PI/2. M = 18 MBDCND = 6 PS = 0.0 PF = PI+PI N = 72 NBDCND = 0 ELMBDA = 0. ! ! GENERATE SINES FOR USE IN SUBSEQUENT COMPUTATIONS ! IDIMF = 19 DTHETA = TF/M MP1 = M+1 DO 101 I=1,MP1 SINT(I) = SIN((I-1)*DTHETA) 101 continue DPHI = (PI+PI)/N NP1 = N+1 DO 102 J=1,NP1 SINP(J) = SIN((J-1)*DPHI) ! ! COMPUTE RIGHT SIDE OF EQUATION AND STORE IN F ! 102 continue DO 104 J=1,NP1 DO 103 I=1,MP1 F(I,J) = 2.-6.*(SINT(I)*SINP(J))**2 103 continue ! ! STORE DERIVATIVE DATA AT THE EQUATOR ! 104 continue DO 105 J=1,NP1 BDTF(J) = 0. ! 105 continue call HWSSSP(TS,TF,M,MBDCND,BDTS,BDTF,PS,PF,N,NBDCND,BDPS,BDPF, & ! ! COMPUTE DISCRETIZATION ERROR. SINCE PROBLEM IS SINGULAR, THE ! SOLUTION MUST BE NORMALIZED. ! ELMBDA,F,IDIMF,PERTRB,IERROR,W) ERR = 0.0 DO 107 J=1,NP1 DO 106 I=1,MP1 Z = ABS(F(I,J)-(SINT(I)*SINP(J))**2-F(1,1)) if ( Z > ERR) ERR = Z 106 continue ! 107 continue ipass = 1 if ( ERR > ERMAX) ipass = 0 if ( kprint == 0) RETURN if ( KPRINT >= 2 .OR. ipass == 0 ) then write (LUN,1001) IERROR,ERR,INT(W(1)) if ( ipass == 1 ) then write (LUN, 1002) else write (LUN, 1003) end if end if ! return 1001 FORMAT ('1',20X,'SUBROUTINE HWSSSP EXAMPLE'/// & 10X,'THE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS'// & 32X,'IERROR = 0'/ & 18X,'DISCRETIZATION ERROR = 3.38107E-03'/ & 12X,'REQUIRED LENGTH OF W ARRAY = 600'// & 10X,'THE OUTPUT FROM YOUR COMPUTER IS'// & 32X,'IERROR =',I2/ & 18X,'DISCRETIZATION ERROR =',1PE12.5 / & 12X,'REQUIRED LENGTH OF W ARRAY =',I4) 1002 FORMAT (60X,'PASS'/) 1003 FORMAT (60X,'FAIL'/) end !! RQRTST !***PURPOSE Quick check for RPQR79. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (RQRTST-S, CQRTST-C) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED NUMXER, PASS, R1MACH, RPQR79, XERCLR, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901010 Restructured using IF-THEN-else-end if, cleaned up FORMATs ! and changed TOL from sqrt R1MACH(3) to sqrt R1MACH(4) for ! the IBM 370 mainframes. (RWC) ! 911010 Code reworked and simplified. (RWC and WRB) !***END PROLOGUE RQRTST subroutine RQRTST (LUN, KPRINT, IPASS) integer ITMP(7) COMPLEX ROOT(7), CHK(7) dimension WORK(63) REAL COEF(8) ! LOGICAL FATAL DATA CHK / ( 1.4142135623731, 1.4142135623731), & ( 1.4142135623731, -1.4142135623731), & (0.0, 2.0), (0.0, -2.0), (-2.0, 0.0), & (-1.4142135623731, 1.4142135623731), & !***FIRST EXECUTABLE STATEMENT RQRTST (-1.4142135623731, -1.4142135623731) / if ( kprint >= 2) write (LUN, 90000) TOL = SQRT(R1MACH(4)) ! ! Initialize variables for testing. ! ipass = 1 BETA = 0.0078125 DO 20 J=1,8 COEF(J) = BETA BETA = 2.0*BETA ! 20 continue ! ! Check to see if test passed. ! call RPQR79 (7, COEF, ROOT, IERR, WORK) DO 10 I=1,7 ITMP(I) = 0 ! ! Check for roots in any order. ! 10 continue DO 40 I=1,7 DO 30 J=1,7 if ( ABS(ROOT(I)-CHK(J)) <= TOL ) then ITMP(J) = 1 GO TO 40 end if 30 continue ! ! Check that we found all 7 roots. ! 40 continue ipass = 1 DO 50 I=1,7 ipass = IPASS*ITMP(I) ! ! Print test results. ! 50 continue if ( KPRINT >= 3 .OR. (KPRINT>=2 .and. ipass == 0) ) then write (LUN, 90010) write (LUN, 90020) (J,COEF(J), J=1,8) write (LUN, 90030) write (LUN, 90040) (J,ROOT(J), J=1,7) end if if ( kprint >= 2 ) then call PASS (LUN, 1, IPASS) ! ! 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 RPQR79 with 0 degree polynomial. ! if ( kprint >= 3) write (LUN, 90060) call RPQR79 (0, COEF, ROOT, IERR, WORK) if ( NUMXER(NERR) /= 3 ) then FATAL = .TRUE. end if ! ! call RPQR79 with zero leading coefficient. ! call xerclr COEF(1) = 0.0 call RPQR79 (2, COEF, 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 ! end if if ( ipass == 1 .and. kprint > 1) write (LUN,90100) if ( ipass == 0 .and. kprint /= 0) write (LUN,90110) ! return 90000 FORMAT ('1', /,' RPQR79 QUICK CHECK') 90010 FORMAT (/, ' CHECK REAL AND IMAGINARY PARTS OF ROOT' / & ' COEFFICIENTS') 90020 FORMAT (/ (I6, 3X, 1P, E22.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) 90060 FORMAT (// ' TRIGGER 2 ERROR CONDITIONS' //) 90070 FORMAT (/ ' AT LEAST ONE INCORRECT ARGUMENT TEST FAILED') 90080 FORMAT (/ ' ALL INCORRECT ARGUMENT TESTS PASSED') 90100 FORMAT (/' **************RPQR79 PASSED ALL TESTS**************') 90110 FORMAT (/' **************RPQR79 FAILED SOME TESTS*************') end !! SBEG !***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 SBEG ! .. Scalar Arguments .. REAL FUNCTION SBEG (RESET) ! .. Local Scalars .. LOGICAL RESET ! .. Save statement .. integer I, IC, MI ! .. Intrinsic Functions .. SAVE I, IC, MI ! ***FIRST EXECUTABLE STATEMENT SBEG INTRINSIC REAL ! 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 SBEG = REAL( I - 500 )/1001.0 ! ! End of SBEG. ! return end !! SBLAT2 !***PURPOSE Driver for testing Level 2 BLAS single precision ! subroutines. !***LIBRARY SLATEC (BLAS) !***CATEGORY A3A !***TYPE SINGLE 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 REAL 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 LSE, R1MACH, SCHK12, SCHK22, SCHK32, SCHK42, ! SCHK52, SCHK62, SCHKE2, SMVCH, 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 SBLAT2 ! .. Parameters .. subroutine SBLAT2 (NOUT, KPRINT, IPASS) integer NSUBS PARAMETER ( NSUBS = 16) REAL ZERO, ONE PARAMETER ( ZERO = 0.0, ONE = 1.0 ) integer NMAX, INCMAX ! .. Scalar Arguments .. PARAMETER ( NMAX = 65, INCMAX = 2 ) ! .. Local Scalars .. integer IPASS, KPRINT LOGICAL FTL, FTL1, FTL2 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 ! .. Local Arrays .. CHARACTER*1 TRANS REAL 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 LSE ! .. External Subroutines .. EXTERNAL LSE, R1MACH EXTERNAL SCHK12, SCHK22, SCHK32, SCHK42, SCHK52, SCHK62, & ! .. Intrinsic Functions .. SCHKE2, SMVCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN DATA SNAMES/'SGEMV ', 'SGBMV ', 'SSYMV ', 'SSBMV ', & 'SSPMV ', 'STRMV ', 'STBMV ', 'STPMV ', & 'STRSV ', 'STBSV ', 'STPSV ', 'SGER ', & 'SSYR ', 'SSPR ', 'SSYR2 ', 'SSPR2 '/ 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 SBLAT2 ! ! 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. ! ! Initialize ipass to 1 assuming everything 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 SMVCH 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 SMVCH YT holds ! the result computed by SMVCH. 130 continue TRANS = 'N' FTL = .FALSE. call SMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G, & YY, EPS, ERR, FTL, NOUT, .TRUE., kprint ) SAME = LSE( 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 SMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G, & YY, EPS, ERR, FTL, NOUT, .TRUE., kprint ) SAME = LSE( 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 SCHKE2( 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, 180, 180, & ! Test SGEMV, 01, and SGBMV, 02. 190, 190 )ISNUM 140 call SCHK12( 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 SSYMV, 03, SSBMV, 04, and SSPMV, 05. GO TO 200 150 call SCHK22( 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 STRMV, 06, STBMV, 07, STPMV, 08, ! STRSV, 09, STBSV, 10, and STPSV, 11. GO TO 200 160 call SCHK32( 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 SGER, 12. GO TO 200 170 call SCHK42( 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 SSYR, 13, and SSPR, 14. GO TO 200 180 call SCHK52( 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 SSYR2, 15, and SSPR2, 16. GO TO 200 190 call SCHK62( 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 REAL 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 SMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', & 'ATED WRONGLY.', /' SMVCH 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 SBLAT2. ! 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) end !! SBLAT3 !***PURPOSE Driver for testing Level 3 BLAS single precision ! subroutines. !***LIBRARY SLATEC (BLAS) !***CATEGORY A3A !***TYPE SINGLE 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 REAL 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 LSE, R1MACH, SCHK13, SCHK23, SCHK33, SCHK43, ! SCHK53, SCHKE3, SMMCH, 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) ! 930701 Call to SCHKE5 changed to call to SCHKE3. (BKS) !***END PROLOGUE SBLAT3 ! .. Parameters .. subroutine SBLAT3 (NOUT, KPRINT, IPASS) integer NSUBS PARAMETER ( NSUBS = 6) REAL ZERO, ONE PARAMETER ( ZERO = 0.0, ONE = 1.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, NOUT PARAMETER (NIDIM=6, NALF=3, NBET=3) LOGICAL SAME, TSTERR, FTL, FTL1, FTL2 ! .. Local Arrays .. CHARACTER*1 TRANSA, TRANSB REAL 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 LSE ! .. External Subroutines .. EXTERNAL LSE, R1MACH EXTERNAL SCHK13, SCHK23, SCHK33, SCHK43, SCHK53, & ! .. Intrinsic Functions .. SCHKE3, SMMCH ! .. Data statements .. INTRINSIC MAX, MIN DATA SNAMES/'SGEMM ', 'SSYMM ', 'STRMM ', 'STRSM ', & 'SSYRK ', 'SSYR2K'/ DATA IDIM/0,1,2,3,5,9/ DATA ALF/0.0,1.0,0.7/ !***FIRST EXECUTABLE STATEMENT SBLAT3 ! ! 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. ! ! Initialize ipass to 1 assuming everything 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 SMMCH using exact data. ! EPS = R1MACH (4) N = min ( 32, NMAX ) DO 120 J = 1, N DO 110 I = 1, N AB( I, J ) = max ( I - J + 1, 0 ) 110 continue AB( J, NMAX + 1 ) = J AB( 1, NMAX + J ) = J C( J, 1 ) = ZERO 120 continue DO 130 J = 1, N CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 ! CC holds the exact result. On exit from SMMCH CT holds ! the result computed by SMMCH. 130 continue TRANSA = 'N' TRANSB = 'N' FTL = .FALSE. call SMMCH( 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 = LSE( 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 SMMCH( 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 = LSE( 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 125 J = 1, N AB( J, NMAX + 1 ) = N - J + 1 AB( 1, NMAX + J ) = N - J + 1 125 continue DO 135 J = 1, N CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - & ( ( J + 1 )*J*( J - 1 ) )/3 135 continue TRANSA = 'T' TRANSB = 'N' FTL = .FALSE. call SMMCH( 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 = LSE( 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 SMMCH( 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 = LSE( 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 210 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 SCHKE3(ISNUM, SNAMES( ISNUM ), NOUT, KPRINT, FTL1) ! Test computations. end if FTL2 = .FALSE. call xerclr ! Test SGEMM, 01. GO TO ( 140, 150, 160, 160, 170, 180) ISNUM 140 call SCHK13( 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 SSYMM, 02. GO TO 200 150 call SCHK23( 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 STRMM, 03, STRSM, 04. GO TO 200 160 call SCHK33( 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 SSYRK, 05. GO TO 200 170 call SCHK43( 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 SSYR2K, 06. GO TO 200 180 call SCHK53( 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 200 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 ) 9995 FORMAT( ' TESTS OF THE REAL 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 SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', & 'ATED WRONGLY.', /' SMMCH 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 SBLAT3. ! 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) end !! SBOCQX !***PURPOSE Quick check for SBOCLS. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SBOCQX-S, DBOCQX-D) !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! MINIMAL TEST DRIVER FOR SBOCLS, 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 R1MACH, SBOCLS, SBOLS, SCOPY, SNRM2 !***REVISION HISTORY (YYMMDD) ! 850310 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901013 Added PASS/FAIL message and cleaned up FORMATs. (RWC) !***END PROLOGUE SBOCQX subroutine SBOCQX (LUN, KPRINT, IPASS) REAL D(6,5),W(11,11),BL(5,2),BU(5,2),X(30),RW(55),XTRUE(9) REAL C(5,5) REAL BL1(10),BU1(10) integer IND(10),IW(20),IOPT(40) REAL RHS(6,2) ! CHARACTER*4 MSG DATA ((C(I,J),I=1,5),J=1,5) /1.,10.,4.,8.,1.,1.,10.,2.,-1.,1.,1., & -3.,-3.,2.,1.,1.,5.,5.,5.,1.,1.,4.,-1.,-3.,1./ DATA ((D(I,J),I=1,6),J=1,5) /-74.,14.,66.,-12.,3.,4.,80.,-69., & -72.,66.,8.,-12.,18.,21.,-5.,-30.,-7.,4.,-11.,28.,7.,-23.,-4., & 4.,-4.,0.,1.,3.,1.,0./ DATA ((BL(I,J),I=1,5),J=1,2) /1.,0.,-1.,1.,-4.,-1.,0.,-3.,1.,-6./ DATA ((BU(I,J),I=1,5),J=1,2) /3.,2.,1.,3.,-2.,3.,4.,1.,5.,-2./ DATA ((RHS(I,J),I=1,6),J=1,2) /51.,-61.,-56.,69.,10.,-12.,-5.,-9., & 708.,4165.,-13266.,8409./ !***FIRST EXECUTABLE STATEMENT SBOCQX DATA (XTRUE(J),J=1,9) /1.,2.,-1.,3.,-4.,1.,32.,30.,31./ 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 SCOPY(MROWS,D(1,J),1,W(1,J),1) ! 10 continue ! ! SET BOUND INDICATOR FLAGS. ! call SCOPY(MROWS,RHS(1,IRHS),1,W(1,NCOLS+1),1) DO 20 J = 1,NCOLS IND(J) = 3 ! 20 continue call SBOLS(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 = SNRM2(NCOLS,X,1) MPASS = 1 if ( SR > 10.E3*SQRT(R1MACH(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 SCOPY(11*10,0.E0,0,W,1) call SCOPY(NCOLS,BL(1,IB),1,BL1,1) call SCOPY(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 SCOPY(MCON,C(1,J),1,W(1,J),1) call SCOPY(MROWS,D(1,J),1,W(MCON+1,J),1) ! 60 continue ! ! CHECK LENGTHS OF REQD. ARRAYS. ! call SCOPY(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 SBOCLS(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 = SNRM2(NCOLS+MCON,X,1) MPASS = 1 if ( SR > 10.E3*SQRT(R1MACH(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 SBOCLS() HAS PASSED ITS TESTS. ! THE VALUE OF IPASS=0 SAYS THAT SBOCLS() 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 SBOCLS OR SBOLS') 99998 FORMAT (' TEST IB IRHS SR') 99999 FORMAT (3I5, 1P, E20.6, ' TEST ', A, 'ED.') end subroutine SCHK12 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NKB, KB, NALF, ALF, NBET, BET, NINC, INC, NMAX, INCMAX, & !! SCHK12 !***SUBSIDIARY !***PURPOSE Quick check for SGEMV and SGBMV. !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for SGEMV and SGBMV. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED LSE, LSERES, NUMXER, SGBMV, SGEMV, SMAKE2, SMVCH !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE SCHK12 ! .. Parameters .. A, AA, AS, X, XX, XS, Y, YY, YS, YT, G) REAL ZERO, HALF ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0, HALF = 0.5 ) LOGICAL FATAL REAL EPS, THRESH integer INCMAX, KPRINT, NALF, NBET, NIDIM, NINC, NKB, & NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME REAL 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 ) REAL 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 LSE, LSERES ! .. External Subroutines .. EXTERNAL LSE, LSERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL SGBMV, SGEMV, SMAKE2, SMVCH ! .. Data statements .. INTRINSIC ABS, MAX, MIN !***FIRST EXECUTABLE STATEMENT SCHK12 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 SMAKE2( 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 SMAKE2( '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 SMAKE2( '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 SGEMV( TRANS, M, N, ALPHA, AA, & LDA, XX, INCX, BETA, YY, & INCY ) else if ( BANDED ) then call SGBMV( 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 ) = LSE( AS, AA, LAA ) ISAME( 6 ) = LDAS == LDA ISAME( 7 ) = LSE( XS, XX, LX ) ISAME( 8 ) = INCXS == INCX ISAME( 9 ) = BLS == BETA if ( NULL ) then ISAME( 10 ) = LSE( YS, YY, LY ) else ISAME( 10 ) = LSERES( '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 ) = LSE( AS, AA, LAA ) ISAME( 8 ) = LDAS == LDA ISAME( 9 ) = LSE( XS, XX, LX ) ISAME( 10 ) = INCXS == INCX ISAME( 11 ) = BLS == BETA if ( NULL ) then ISAME( 12 ) = LSE( YS, YY, LY ) else ISAME( 12 ) = LSERES( '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 SMVCH( 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 SCHK12. ! '******' ) end subroutine SCHK13 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NBET, BET, NMAX, A, AA, AS, B, BB, BS, C, CC, & !! SCHK13 !***SUBSIDIARY !***PURPOSE Quick check for SGEMM. !***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 SGEMM. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED LSE, LSERES, NUMXER, SGEMM, SMAKE3, SMMCH !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE SCHK13 ! .. Parameters .. CS, CT, G) REAL ZERO ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0 ) LOGICAL FATAL REAL EPS, THRESH integer KPRINT, NALF, NBET, NIDIM, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), & B( NMAX, NMAX ), BB( NMAX*NMAX ), & BS( NMAX*NMAX ), C( NMAX, NMAX ), & CC( NMAX*NMAX ), CS( NMAX*NMAX ), & CT( NMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ) REAL 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 LSE, LSERES ! .. External Subroutines .. EXTERNAL LSE, LSERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL SGEMM, SMAKE3, SMMCH ! .. Data statements .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT SCHK13 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 SMAKE3( '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 SMAKE3( '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 SMAKE3( '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 SGEMM( 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 ) = LSE( AS, AA, LAA ) ISAME( 8 ) = LDAS == LDA ISAME( 9 ) = LSE( BS, BB, LBB ) ISAME( 10 ) = LDBS == LDB ISAME( 11 ) = BLS == BETA if ( NULL ) then ISAME( 12 ) = LSE( CS, CC, LCC ) else ISAME( 12 ) = LSERES( '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 SMMCH( 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 SCHK13. ! '******' ) end subroutine SCHK22 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NKB, KB, NALF, ALF, NBET, BET, NINC, INC, NMAX, INCMAX, & !! SCHK22 !***SUBSIDIARY !***PURPOSE Quick check for SSYMV, SSBMV and SSPMV. !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for SSYMV, SSBMV and SSPMV. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED LSE, LSERES, NUMXER, SMAKE2, SMVCH, SSBMV, SSPMV, ! SSYMV !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE SCHK22 ! .. Parameters .. A, AA, AS, X, XX, XS, Y, YY, YS, YT, G) REAL ZERO, HALF ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0, HALF = 0.5 ) LOGICAL FATAL REAL EPS, THRESH integer INCMAX, KPRINT, NALF, NBET, NIDIM, NINC, NKB, & NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME REAL 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 ) REAL 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 LSE, LSERES ! .. External Subroutines .. EXTERNAL LSE, LSERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL SMAKE2, SMVCH, SSBMV, SSPMV, SSYMV ! .. Data statements .. INTRINSIC ABS, MAX !***FIRST EXECUTABLE STATEMENT SCHK22 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 SMAKE2( 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 SMAKE2( '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 SMAKE2( '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 SSYMV( UPLO, N, ALPHA, AA, LDA, XX, & INCX, BETA, YY, INCY ) else if ( BANDED ) then call SSBMV( UPLO, N, K, ALPHA, AA, LDA, & XX, INCX, BETA, YY, INCY ) else if ( PACKED ) then call SSPMV( 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 ) = LSE( AS, AA, LAA ) ISAME( 5 ) = LDAS == LDA ISAME( 6 ) = LSE( XS, XX, LX ) ISAME( 7 ) = INCXS == INCX ISAME( 8 ) = BLS == BETA if ( NULL ) then ISAME( 9 ) = LSE( YS, YY, LY ) else ISAME( 9 ) = LSERES( '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 ) = LSE( AS, AA, LAA ) ISAME( 6 ) = LDAS == LDA ISAME( 7 ) = LSE( XS, XX, LX ) ISAME( 8 ) = INCXS == INCX ISAME( 9 ) = BLS == BETA if ( NULL ) then ISAME( 10 ) = LSE( YS, YY, LY ) else ISAME( 10 ) = LSERES( 'GE', ' ', 1, N, & YS, YY, ABS( INCY ) ) end if ISAME( 11 ) = INCYS == INCY else if ( PACKED ) then ISAME( 3 ) = ALS == ALPHA ISAME( 4 ) = LSE( AS, AA, LAA ) ISAME( 5 ) = LSE( XS, XX, LX ) ISAME( 6 ) = INCXS == INCX ISAME( 7 ) = BLS == BETA if ( NULL ) then ISAME( 8 ) = LSE( YS, YY, LY ) else ISAME( 8 ) = LSERES( '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 SMVCH( '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, K, 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, ', 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 SCHK22. ! '******' ) end subroutine SCHK23 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NBET, BET, NMAX, A, AA, AS, B, BB, BS, C, CC, & !! SCHK23 !***SUBSIDIARY !***PURPOSE Quick check for SSYMM. !***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 SSYMM. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED LSE, LSERES, NUMXER, SMAKE3, SMMCH, SSYMM !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE SCHK23 ! .. Parameters .. CS, CT, G) REAL ZERO ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0 ) LOGICAL FATAL REAL EPS, THRESH integer KPRINT, NALF, NBET, NIDIM, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), & B( NMAX, NMAX ), BB( NMAX*NMAX ), & BS( NMAX*NMAX ), C( NMAX, NMAX ), & CC( NMAX*NMAX ), CS( NMAX*NMAX ), & CT( NMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ) REAL 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, NULL, RESET, LEFT CHARACTER*1 SIDE, SIDES, UPLO, UPLOS ! .. Local Arrays .. CHARACTER*2 ICHS, ICHU ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LSE, LSERES ! .. External Subroutines .. EXTERNAL LSE, LSERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL SSYMM, SMAKE3, SMMCH ! .. Data statements .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT SCHK23 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 SMAKE3( '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 SMAKE3('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 SMAKE3( '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 SSYMM( 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 ) = LSE( AS, AA, LAA ) ISAME( 7 ) = LDAS == LDA ISAME( 8 ) = LSE( BS, BB, LBB ) ISAME( 9 ) = LDBS == LDB ISAME( 10 ) = BLS == BETA if ( NULL ) then ISAME( 11 ) = LSE( CS, CC, LCC ) else ISAME( 11 ) = LSERES( '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 SMMCH( '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 SMMCH( '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 SCHK23. ! '******' ) end subroutine SCHK32 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NKB, KB, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, & !! SCHK32 !***SUBSIDIARY !***PURPOSE Quick check for STRMV, STBMV, STPMV, STRSV, STBSV and ! STPSV. !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for STRMV, STBMV, STPMV, STRSV, STBSV and STPSV. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED LSE, LSERES, NUMXER, SMAKE2, SMVCH, STBMV, STBSV, ! STPMV, STPSV, STRMV, STRSV !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE SCHK32 ! .. Parameters .. XT, G, Z) REAL ZERO, HALF, ONE ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) LOGICAL FATAL REAL EPS, THRESH integer INCMAX, KPRINT, NIDIM, NINC, NKB, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME REAL 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 ) REAL 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 LSE, LSERES ! .. External Subroutines .. EXTERNAL LSE, LSERES, NUMXER EXTERNAL SMAKE2, SMVCH, STBMV, STBSV, STPMV, STPSV, & ! .. Intrinsic Functions .. STRMV, STRSV ! .. Data statements .. INTRINSIC ABS, MAX !***FIRST EXECUTABLE STATEMENT SCHK32 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 SMVCH. 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 SMAKE2( 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 SMAKE2( '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 STRMV( UPLO, TRANS, DIAG, N, AA, LDA, & XX, INCX ) else if ( BANDED ) then call STBMV( UPLO, TRANS, DIAG, N, K, AA, & LDA, XX, INCX ) else if ( PACKED ) then call STPMV( UPLO, TRANS, DIAG, N, AA, XX, & INCX ) end if else if ( SNAME( 4: 5 ) == 'SV' ) then if ( FULL ) then call STRSV( UPLO, TRANS, DIAG, N, AA, LDA, & XX, INCX ) else if ( BANDED ) then call STBSV( UPLO, TRANS, DIAG, N, K, AA, & LDA, XX, INCX ) else if ( PACKED ) then call STPSV( 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 ) = LSE( AS, AA, LAA ) ISAME( 6 ) = LDAS == LDA if ( NULL ) then ISAME( 7 ) = LSE( XS, XX, LX ) else ISAME( 7 ) = LSERES( 'GE', ' ', 1, N, XS, & XX, ABS( INCX ) ) end if ISAME( 8 ) = INCXS == INCX else if ( BANDED ) then ISAME( 5 ) = KS == K ISAME( 6 ) = LSE( AS, AA, LAA ) ISAME( 7 ) = LDAS == LDA if ( NULL ) then ISAME( 8 ) = LSE( XS, XX, LX ) else ISAME( 8 ) = LSERES( 'GE', ' ', 1, N, XS, & XX, ABS( INCX ) ) end if ISAME( 9 ) = INCXS == INCX else if ( PACKED ) then ISAME( 5 ) = LSE( AS, AA, LAA ) if ( NULL ) then ISAME( 6 ) = LSE( XS, XX, LX ) else ISAME( 6 ) = LSERES( '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 SMVCH( 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 SMVCH( 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 SCHK32. ! '******' ) end subroutine SCHK33 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & !! SCHK33 !***SUBSIDIARY !***PURPOSE Quick check for STRMM and STRSM. !***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 STRMM and STRSM. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED LSE, LSERES, NUMXER, SMAKE3, SMMCH, STRMM, STRSM !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE SCHK33 ! .. Parameters .. IDIM, NALF, ALF, NMAX, A, AA, AS, B, BB, BS, CT, G, C) REAL ZERO, ONE ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0, ONE = 1.0) LOGICAL FATAL REAL EPS, THRESH integer KPRINT, NALF, NIDIM, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), & AS( NMAX*NMAX ), G( NMAX ), & B( NMAX, NMAX ), BB( NMAX*NMAX ), & BS( NMAX*NMAX ), C( NMAX, NMAX ), & CT( NMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ) REAL 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, NULL, RESET, LEFT CHARACTER*1 SIDE, SIDES, UPLO, UPLOS, TRANAS, TRANSA, DIAG, & DIAGS CHARACTER*2 ICHS, ICHU, ICHD ! .. Local Arrays .. CHARACTER*3 ICHT ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LSE, LSERES ! .. External Subroutines .. EXTERNAL LSE, LSERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL STRMM, STRSM, SMAKE3, SMMCH ! .. Data statements .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT SCHK33 DATA ICHT/'NTC'/, ICHU/'UL'/, ICHD/'UN'/, ICHS/'LR'/ ! NARGS = 11 NC = 0 RESET = .TRUE. ! ! Set up zero matrix for SMMCH. 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 SMAKE3( 'TR', UPLO, DIAG, NA, NA, A, & ! ! Generate the matrix B. ! NMAX, AA, LDA, RESET, ZERO ) call SMAKE3( '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 STRMM( SIDE, UPLO, TRANSA, DIAG, M, & N, ALPHA, AA, LDA, BB, LDB ) else if ( SNAME( 4: 5 ) == 'SM' ) then call STRSM( 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 ) = LSE( AS, AA, LAA ) ISAME( 9 ) = LDAS == LDA if ( NULL ) then ISAME( 10 ) = LSE( BS, BB, LBB ) else ISAME( 10 ) = LSERES( '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 SMMCH( 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 SMMCH( '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 SMMCH( 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 SMMCH( '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 SCHK33. ! '******' ) end subroutine SCHK42 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, & !! SCHK42 !***SUBSIDIARY !***PURPOSE Quick check for SGER. !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for SGER. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED LSE, LSERES, NUMXER, SGER, SMAKE2, SMVCH !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE SCHK42 ! .. Parameters .. Y, YY, YS, YT, G, Z) REAL ZERO, HALF, ONE ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) LOGICAL FATAL REAL EPS, THRESH integer INCMAX, KPRINT, NALF, NIDIM, NINC, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME REAL 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 ) REAL 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 REAL W( 1 ) ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LSE, LSERES ! .. External Subroutines .. EXTERNAL LSE, LSERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL SGER, SMAKE2, SMVCH !***FIRST EXECUTABLE STATEMENT SCHK42 ! 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 SMAKE2( '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 SMAKE2( '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 SMAKE2(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 SGER( 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 ) = LSE( XS, XX, LX ) ISAME( 5 ) = INCXS == INCX ISAME( 6 ) = LSE( YS, YY, LY ) ISAME( 7 ) = INCYS == INCY if ( NULL ) then ISAME( 8 ) = LSE( AS, AA, LAA ) else ISAME( 8 ) = LSERES( '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 SMVCH( '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 SCHK42. ! '******' ) end subroutine SCHK43 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NBET, BET, NMAX, A, AA, AS, B, BB, BS, C, CC, & !! SCHK43 !***SUBSIDIARY !***PURPOSE Quick check for SSYRK. !***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 SSYRK. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED LSE, LSERES, NUMXER, SMAKE3, SMMCH, SSYRK !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE SCHK43 ! .. Parameters .. CS, CT, G) REAL ZERO, ONE ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0, ONE = 1.0) LOGICAL FATAL REAL EPS, THRESH integer KPRINT, NALF, NBET, NIDIM, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME REAL A( NMAX, NMAX), AA( NMAX*NMAX), ALF( NALF), & AS( NMAX*NMAX ), BET( NBET ), G( NMAX ), & B( NMAX, NMAX ), BB( NMAX*NMAX ), & BS( NMAX*NMAX ), C( NMAX, NMAX ), & CC( NMAX*NMAX ), CS( NMAX*NMAX ), & CT( NMAX ) ! .. Local Scalars .. integer IDIM( NIDIM ) REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX integer I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, LAA, & LCC, LDA, LDAS, LDC, LDCS, & N, NA, NARGS, NC, NERR, NS, KS, LJ, MA LOGICAL FTL, NULL, RESET, TRAN, UPPER CHARACTER*1 UPLO, UPLOS, TRANS, TRANSS CHARACTER*2 ICHU ! .. Local Arrays .. CHARACTER*3 ICHT ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LSE, LSERES ! .. External Subroutines .. EXTERNAL LSE, LSERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL SSYRK, SMAKE3, SMMCH ! .. Data statements .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT SCHK43 DATA ICHT/'NTC'/, ICHU/'UL'/ ! 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 SMAKE3( '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 SMAKE3( '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 SSYRK( UPLO, TRANS, N, K, ALPHA, AA, LDA, & BETA, CC, LDC ) ! ! Check if error-exit was taken incorrectly. ! 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 ) = LSE( AS, AA, LAA ) ISAME( 7 ) = LDAS == LDA ISAME( 8 ) = BETS == BETA if ( NULL ) then ISAME( 9 ) = LSE( CS, CC, LCC ) else ISAME( 9 ) = LSERES( '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 SMMCH( '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 SMMCH( '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 SCHK43. ! '******' ) end subroutine SCHK52 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, & !! SCHK52 !***SUBSIDIARY !***PURPOSE Quick check for SSYR and SSPR. !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for SSYR and SSPR. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED LSE, LSERES, NUMXER, SMAKE2, SMVCH, SSPR, SSYR !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE SCHK52 ! .. Parameters .. Y, YY, YS, YT, G, Z) REAL ZERO, HALF, ONE ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) LOGICAL FATAL REAL EPS, THRESH integer INCMAX, KPRINT, NALF, NIDIM, NINC, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME REAL 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 ) REAL 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 REAL W( 1 ) ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LSE, LSERES ! .. External Subroutines .. EXTERNAL LSE, LSERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL SMAKE2, SMVCH, SSPR, SSYR ! .. Data statements .. INTRINSIC ABS, MAX !***FIRST EXECUTABLE STATEMENT SCHK52 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 SMAKE2( '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 SMAKE2( 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 SSYR( UPLO, N, ALPHA, XX, INCX, AA, LDA ) else if ( PACKED ) then call SSPR( 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 ) = LSE( XS, XX, LX ) ISAME( 5 ) = INCXS == INCX if ( NULL ) then ISAME( 6 ) = LSE( AS, AA, LAA ) else ISAME( 6 ) = LSERES( 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 ! ! 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 SMVCH( '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 ) 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 60 continue ! 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 subroutine SCHK53 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NBET, BET, NMAX, AB, AA, AS, BB, BS, C, CC, & !! SCHK53 !***SUBSIDIARY !***PURPOSE Quick check for SSYR2K. !***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 SSYR2K. ! ! Auxiliary routine for test program for Level 3 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED LSE, LSERES, NUMXER, SMAKE3, SMMCH, SSYR2K !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE SCHK53 ! .. Parameters .. CS, CT, G, W) REAL ZERO ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0) LOGICAL FATAL REAL EPS, THRESH integer KPRINT, NALF, NBET, NIDIM, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME REAL 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 ), AB(2*NMAX*NMAX) ! .. Local Scalars .. integer IDIM( NIDIM ) REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX integer I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, LAA, & LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, & N, NA, NARGS, NC, NERR, NS, KS, LJ, MA, JJAB LOGICAL FTL, NULL, RESET, TRAN, UPPER CHARACTER*1 UPLO, UPLOS, TRANS, TRANSS CHARACTER*2 ICHU ! .. Local Arrays .. CHARACTER*3 ICHT ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LSE, LSERES ! .. External Subroutines .. EXTERNAL LSE, LSERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL SSYR2K, SMAKE3, SMMCH ! .. Data statements .. INTRINSIC MAX !***FIRST EXECUTABLE STATEMENT SCHK53 DATA ICHT/'NTC'/, ICHU/'UL'/ ! 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 SMAKE3( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, & LDA, RESET, ZERO ) else call SMAKE3('GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, & RESET, ZERO ) ! ! Generate the matrix B. ! end if LDB = LDA LBB = LAA if ( TRAN ) then call SMAKE3( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), & 2*NMAX, BB, LDB, RESET, ZERO ) else call SMAKE3( '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 SMAKE3( '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 I = 1, LAA AS( I ) = AA( I ) end do 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 SSYR2K( 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 ) = LSE( AS, AA, LAA ) ISAME( 7 ) = LDAS == LDA ISAME( 8 ) = LSE( BS, BB, LBB ) ISAME( 9 ) = LDBS == LDB ISAME( 10 ) = BETS == BETA if ( NULL ) then ISAME( 11 ) = LSE( CS, CC, LCC ) else ISAME( 11 ) = LSERES( '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 ! ! 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 FTL = .FALSE. call SMMCH( '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 FTL = .FALSE. call SMMCH( '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 ) 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 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, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', & ' .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID call *', & '******' ) end subroutine SCHK62 (SNAME, EPS, THRESH, NOUT, KPRINT, FATAL, NIDIM, & IDIM, NALF, ALF, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX, XS, & !! SCHK62 !***SUBSIDIARY !***PURPOSE Quick check for SSYR2 and SSPR2. !***LIBRARY SLATEC (BLAS) !***KEYWORDS BLAS, QUICK CHECK SERVICE ROUTINE !***AUTHOR Du Croz, J. (NAG) ! Hanson, R. J. (SNLA) !***DESCRIPTION ! ! Quick check for SSYR2 and SSPR2. ! ! Auxiliary routine for test program for Level 2 Blas. !***REFERENCES (NONE) !***ROUTINES CALLED LSE, LSERES, NUMXER, SMAKE2, SMVCH, SSPR2, SSYR2 !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910619 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE SCHK62 ! .. Parameters .. Y, YY, YS, YT, G, Z) REAL ZERO, HALF, ONE ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) LOGICAL FATAL REAL EPS, THRESH integer INCMAX, KPRINT, NALF, NIDIM, NINC, NMAX, NOUT ! .. Array Arguments .. CHARACTER*6 SNAME REAL 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 ) REAL 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 REAL W( 2 ) ! .. External Functions .. LOGICAL ISAME( 13 ) integer NUMXER LOGICAL LSE, LSERES ! .. External Subroutines .. EXTERNAL LSE, LSERES, NUMXER ! .. Intrinsic Functions .. EXTERNAL SMAKE2, SMVCH, SSPR2, SSYR2 ! .. Data statements .. INTRINSIC ABS, MAX !***FIRST EXECUTABLE STATEMENT SCHK62 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 SMAKE2( '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 SMAKE2( '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 SMAKE2( 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 SSYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY, & AA, LDA ) else if ( PACKED ) then call SSPR2( 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 ) = LSE( XS, XX, LX ) ISAME( 5 ) = INCXS == INCX ISAME( 6 ) = LSE( YS, YY, LY ) ISAME( 7 ) = INCYS == INCY if ( NULL ) then ISAME( 8 ) = LSE( AS, AA, LAA ) else ISAME( 8 ) = LSERES( 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 I = 1, NARGS if ( .NOT. ISAME( I ) ) then FATAL = .TRUE. if ( kprint >= 2 ) then write ( NOUT, FMT = 9998 )I end if end if end do FTL = .FALSE. ! ! Check the result column by column. ! if ( .NOT.NULL ) then if ( INCX > 0 ) then DO I = 1, N Z( I, 1 ) = X( I ) end do 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 call SMVCH( '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 !! SCHKE2 !***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, SGBMV, SGEMV, SGER, SSBMV, SSPMV, SSPR, ! SSPR2, SSYMV, SSYR, SSYR2, STBMV, STBSV, STPMV, ! STPSV, STRMV, STRSV, XERCLR, XERDMP, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE SCHKE2 ! .. Scalar Arguments .. subroutine SCHKE2 (ISNUM, SRNAMT, NOUT, KPRINT, FATAL) LOGICAL FATAL integer ISNUM, KPRINT, NOUT ! .. Scalars in Common .. CHARACTER*6 SRNAMT ! .. Local Scalars .. integer INFOT REAL ALPHA, BETA ! .. Local Arrays .. integer KONTRL ! .. External Subroutines .. REAL A( 1, 1), X( 1), Y( 1) EXTERNAL CHKXER, SGBMV, SGEMV, SGER, SSBMV, SSPMV, SSPR, & SSPR2, SSYMV, SSYR, SSYR2, STBMV, STBSV, STPMV, & !***FIRST EXECUTABLE STATEMENT SCHKE2 STPSV, STRMV, STRSV 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 SGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call SGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call SGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call SGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call SGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call SGEMV( '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 SGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call SGBMV( '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 SGBMV( '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 SGBMV( '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 SGBMV( '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 SGBMV( '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 SGBMV( '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 SGBMV( '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 SSYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call SSYMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call SSYMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SSYMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call SSYMV( '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 SSBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call SSBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call SSBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call SSBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call SSBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call SSBMV( '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 SSPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call SSPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call SSPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call SSPMV( '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 STRMV( '/', 'N', 'N', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call STRMV( 'U', '/', 'N', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call STRMV( 'U', 'N', '/', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call STRMV( 'U', 'N', 'N', -1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRMV( 'U', 'N', 'N', 2, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call STRMV( 'U', 'N', 'N', 0, A, 1, X, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 70 INFOT = 1 call xerclr call STBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call STBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call STBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call STBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call STBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STBMV( '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 STPMV( '/', 'N', 'N', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call STPMV( 'U', '/', 'N', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call STPMV( 'U', 'N', '/', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call STPMV( 'U', 'N', 'N', -1, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call STPMV( 'U', 'N', 'N', 0, A, X, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 90 INFOT = 1 call xerclr call STRSV( '/', 'N', 'N', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call STRSV( 'U', '/', 'N', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call STRSV( 'U', 'N', '/', 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call STRSV( 'U', 'N', 'N', -1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRSV( 'U', 'N', 'N', 2, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 8 call xerclr call STRSV( 'U', 'N', 'N', 0, A, 1, X, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 100 INFOT = 1 call xerclr call STBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call STBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call STBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call STBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call STBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STBSV( '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 STPSV( '/', 'N', 'N', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call STPSV( 'U', '/', 'N', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call STPSV( 'U', 'N', '/', 0, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call STPSV( 'U', 'N', 'N', -1, A, X, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call STPSV( 'U', 'N', 'N', 0, A, X, 0 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 120 INFOT = 1 call xerclr call SGER( -1, 0, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call SGER( 0, -1, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call SGER( 0, 0, ALPHA, X, 0, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SGER( 0, 0, ALPHA, X, 1, Y, 0, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call SGER( 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 SSYR( '/', 0, ALPHA, X, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call SSYR( 'U', -1, ALPHA, X, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call SSYR( 'U', 0, ALPHA, X, 0, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SSYR( 'U', 2, ALPHA, X, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 140 INFOT = 1 call xerclr call SSPR( '/', 0, ALPHA, X, 1, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call SSPR( 'U', -1, ALPHA, X, 1, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call SSPR( 'U', 0, ALPHA, X, 0, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) GO TO 170 150 INFOT = 1 call xerclr call SSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call SSYR2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call SSYR2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SSYR2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call SSYR2( '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 SSPR2( '/', 0, ALPHA, X, 1, Y, 1, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call SSPR2( 'U', -1, ALPHA, X, 1, Y, 1, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call SSPR2( 'U', 0, ALPHA, X, 0, Y, 1, A ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SSPR2( '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 !! SCHKE3 !***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, SGEMM, SSYMM, SSYR2K, SSYRK, STRMM, STRSM, ! XERCLR, XERDMP, XGETF, XSETF !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) ! 930701 Name changed from SCHKE5 to SCHKE3. (BKS) !***END PROLOGUE SCHKE3 ! .. Scalar Arguments .. subroutine SCHKE3 (ISNUM, SRNAMT, NOUT, KPRINT, FATAL) LOGICAL FATAL integer ISNUM, KPRINT, NOUT ! .. Scalars in Common .. CHARACTER*6 SRNAMT ! .. Local Scalars .. integer INFOT REAL ALPHA, BETA ! .. Local Arrays .. integer KONTRL ! .. External Subroutines .. REAL A( 1, 1), B( 1, 1), C( 1, 1) EXTERNAL CHKXER, SGEMM, SSYMM, SSYR2K, SSYRK, STRMM, & !***FIRST EXECUTABLE STATEMENT SCHKE3 STRSM 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 SGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 1 call xerclr call SGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call SGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call SGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SGEMM( '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 SSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call SSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call SSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call SSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call SSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call SSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call SSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call SSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call SSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call SSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call SSYMM( '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 STRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call STRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call STRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call STRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call STRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call STRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call STRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call STRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call STRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call STRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call STRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call STRMM( '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 STRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call STRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call STRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call STRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 5 call xerclr call STRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 6 call xerclr call STRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call STRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call STRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call STRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call STRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call STRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call STRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call STRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call STRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 11 call xerclr call STRSM( '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 SSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call SSYRK( 'U', '/', 0, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call SSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call SSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call SSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call SSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call SSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call SSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call SSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call SSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call SSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call SSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call SSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 10 call xerclr call SSYRK( '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 SSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 2 call xerclr call SSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call SSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call SSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call SSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 3 call xerclr call SSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call SSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call SSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call SSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 4 call xerclr call SSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 7 call xerclr call SSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call SSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 9 call xerclr call SSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call SSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) call CHKXER( SRNAMT, INFOT, NOUT, FATAL, kprint ) INFOT = 12 call xerclr call SSYR2K( '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 subroutine sdasqc ( lun, kprint, ipass ) !*****************************************************************************80 ! !! SDASQC is a quick check for SLATEC routine SDASSL. ! !***LIBRARY SLATEC (DASSL) !***CATEGORY I1A2 !***TYPE SINGLE PRECISION (SDASQC-S, DDASQC-D) !***KEYWORDS QUICK CHECK, SDASSL !***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 SDASSL. ! ! SDASSL 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 ! SDASQC with kprint = 3. ! !***REFERENCES (NONE) !***ROUTINES CALLED EDIT2, SDASSL, SDJAC1, SDJAC2, SDRES1, SDRES2 !***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) ! 901030 Made all declarations explicit; added 1P's to formats. (FNF) !***END PROLOGUE SDASQC ! integer LUN, KPRINT, IPASS ! EXTERNAL EDIT2, SDASSL, SDJAC1, SDJAC2, SDRES1, SDRES2 integer I, IDID, INFO(15), IOUT, IPAR(1), IRES, IWORK(45), & J190, J290, LIW, LRW, ML, MU, NEQ, NERR, NFE, NJE, NOUT, & NQU, NST REAL 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 SDASQC data tout1/1.0e0/ data dtout/1.0e0/ ipass = 1 nerr = 0 rtol = 0.0e0 atol = 1.0e-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 SDASSL',/// & 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,E10.1,' ATOL =',E10.1) do j190 = 1, 2 info(1:15) = 0 if ( j190 == 2) then info(5) = 1 end if if ( 2 < kprint ) then write (lun,120) info(5) end if 120 format(////1x,' INFO(5) =',I3// & 6X,'T',15X,'X1',14X,'X2',12X,'NQ',6X,'H',12X/) t = 0.0e0 y(1) = 1.0e0 y(2) = 0.0e0 yprime(1) = -10.0e0 yprime(2) = 10.0e0 tout = tout1 ero = 0.0e0 do iout = 1, nout call sdassl(sdres1,neq,t,y,yprime,tout,info,rtol,atol,idid, & rwork,lrw,iwork,liw,rpar,ipar,sdjac1) hu = rwork(7) nqu = iwork(8) if ( 2 < kprint ) then write (lun,140) t,y(1),y(2),nqu,hu end if 140 format(1x,1p,e15.5,e16.5,e16.5,i6,e14.3) if ( idid < 0 ) then exit end if ! ! G95 experiences bizarre fatal underflows if the argument ! to EXP results in a very small value. Even trying to ! forestall problems by then comparing the result to ! EPSILON causes an error. ! if ( t <= 7.0 ) then yt1 = exp ( -10.0e0 * t ) else yt1 = 0.0 end if if ( epsilon ( 1.0e0 ) < abs ( yt1 ) ) then yt2 = 1.0e0 - yt1 else yt2 = 1.0e0 end if er1 = abs(yt1 - y(1)) er2 = abs(yt2 - y(2)) er = max ( er1,er2)/atol ero = max ( ero,er) if ( er > 1000.0e0 ) then if ( 2 <= kprint ) write (lun,150) t 150 FORMAT(//' Warning.. Error exceeds 1000 * TOLERANCE', & ' WHEN T =',1P,E13.5//) nerr = nerr + 1 end if tout = tout + dtout end do if ( idid < 0 ) then if ( kprint >= 2) write (lun, 176) idid, t 176 format (//'TROUBLE.. SDASSL RETURNED IDID =',I4, & ' WHEN T =',1P,E13.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,E10.2) end do ! ! Second problem ! 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 SDASSL',/// & 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,E10.1,' ATOL =',E10.1) do j290 = 1, 2 info(1:15) = 0 info(6) = 1 if ( j290 == 2) then info(5) = 1 endif 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.0e0 y(1) = 1.0e0 y(2:neq) = 1.0e+00 delta(1:neq) = 0.0e0 ! ! Initialize YPRIME. ! call sdres2 ( t, y, delta, yprime, ires, rpar, ipar ) tout = 0.01e0 ero = 0.0e0 do iout = 1,nout call sdassl(sdres2,neq,t,y,yprime,tout,info,rtol,atol,idid, & rwork,lrw,iwork,liw,rpar,ipar,sdjac2) call edit2(y,t,erm) hu = rwork(7) nqu = iwork(8) if ( kprint > 2) write (lun,240) t,erm,nqu,hu 240 format(1x,1p,e15.5,e14.3,i6,e14.3) if ( idid < 0) then exit end if er = erm/atol ero = max ( ero,er) if ( er > 1000.0e0 ) then if ( kprint >= 2) write (lun,150) t nerr = nerr + 1 end if tout = tout*10.0e0 end do 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 ( 2 < kprint ) then write (lun,180) nst,nfe,nje,ero end if end do if ( kprint >= 2) write (lun,300) nerr 300 FORMAT(////' 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 (/,' ----------SDASSL passed all tests----------') 800 FORMAT (/,' **********SDASSL failed some tests*********') return end !! SDF !***SUBSIDIARY !***PURPOSE Quick check for SLATEC routines SDRIV1, SDRIV2 and SDRIV3. !***LIBRARY SLATEC (SDRIVE) !***CATEGORY I1A2, I1A1B !***TYPE SINGLE PRECISION (SDF-S, DDF-D, CDF-C) !***KEYWORDS QUICK CHECK, SDRIV1, SDRIV2, SDRIV3 !***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 SDQCK !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 890405 DATE WRITTEN ! 890405 Revised to meet SLATEC standards. !***END PROLOGUE SDF subroutine SDF (N, T, Y, YP) REAL ALFA, T, Y(*), YP(*) !***FIRST EXECUTABLE STATEMENT SDF 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 !! SDJAC1 !***SUBSIDIARY !***PURPOSE First Jacobian evaluator for SDASQC. !***LIBRARY SLATEC (DASSL) !***TYPE SINGLE PRECISION (SDJAC1-S, DDJAC1-D) !***AUTHOR PETZOLD, LINDA R., (LLNL) !***SEE ALSO SDASQC !***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 SDJAC1 subroutine SDJAC1 (T, Y, YPRIME, PD, CJ, RPAR, IPAR) integer IPAR(*) !***FIRST EXECUTABLE STATEMENT SDJAC1 REAL T, Y(*), YPRIME(*), PD(2,2), CJ, RPAR(*) PD(1,1) = CJ + 10.0E0 PD(1,2) = 0.0E0 PD(2,1) = 1.0E0 PD(2,2) = 1.0E0 return end !! SDJAC2 !***SUBSIDIARY !***PURPOSE Second Jacobian evaluator for SDASQC. !***LIBRARY SLATEC (DASSL) !***TYPE SINGLE PRECISION (SDJAC2-S, DDJAC2-D) !***AUTHOR PETZOLD, LINDA R., (LLNL) !***SEE ALSO SDASQC !***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 SDJAC2 subroutine SDJAC2 (T, Y, YPRIME, PD, CJ, RPAR, IPAR) integer IPAR(*) REAL T, Y(*), YPRIME(*), PD(11,25), CJ, RPAR(*) integer J, MBAND, ML, MU, NEQ, NG REAL ALPH1, ALPH2 DATA ALPH1/1.0E0/, ALPH2/1.0E0/, NG/5/ !***FIRST EXECUTABLE STATEMENT SDJAC2 DATA ML/5/, MU/0/, NEQ/25/ MBAND = ML + MU + 1 DO 10 J = 1,NEQ PD(MBAND,J) = -2.0E0 - CJ PD(MBAND+1,J) = ALPH1 PD(MBAND+2,J) = 0.0E0 PD(MBAND+3,J) = 0.0E0 PD(MBAND+4,J) = 0.0E0 10 PD(MBAND+5,J) = ALPH2 DO 20 J = 1,NEQ,NG 20 PD(MBAND+1,J) = 0.0E0 return end !! SDQCK !***PURPOSE Quick check for SLATEC routines SDRIV1, SDRIV2 and SDRIV3. !***LIBRARY SLATEC (SDRIVE) !***CATEGORY I1A2, I1A1B !***TYPE SINGLE PRECISION (SDQCK-S, DDQCK-D, CDQCK-C) !***KEYWORDS QUICK CHECK, SDRIV1, SDRIV2, SDRIV3 !***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 R1MACH, SDF, SDRIV1, SDRIV2, SDRIV3, XERCLR !***REVISION HISTORY (YYMMDD) ! 890405 DATE WRITTEN ! 890405 Revised to meet SLATEC standards. !***END PROLOGUE SDQCK subroutine SDQCK (LUN, KPRINT, IPASS) EXTERNAL SDF REAL ALFA, 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(ALFA = 1.E0, 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) REAL WORK(LENWMX), Y(N+1) integer IWORK(LIWMX) !***FIRST EXECUTABLE STATEMENT SDQCK DATA EWT(1) /.00001E0/ EPS = R1MACH(4)**(1.E0/3.E0) ! Exercise SDRIV1 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 SDRIV1 (N, T, Y, SDF, 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.E0 - Y(1)*1.5E0) <= EPS**(2.E0/3.E0) .and. & ABS(1.E0 - Y(2)*3.E0) <= EPS**(2.E0/3.E0) .and. & ABS(1.E0 - Y(3)) <= EPS**(2.E0/3.E0) ) then if ( kprint == 2 ) then WRITE ( LUN, '(a)' ) 'SDRIV1: The solution is accurate enough.' else if ( kprint == 3 ) then WRITE ( LUN, '(a)' ) 'SDRIV1: The solution is accurate enough.' 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, '(a)' ) 'SDRIV1: The solution is not accurate enough.' else if ( kprint == 2 ) then WRITE ( LUN, '(a)' ) 'SDRIV1: The solution is not accurate enough.' WRITE ( LUN, '(a)' ) ' Relevant 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 SDRIV1, a solution was not obtained.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' While using SDRIV1, 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 SDRIV1 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 SDRIV1 (NX, T, Y, SDF, TOUT, MSTATE, EPS, WORK, LENW, IERFLG) if ( IERFLG == 21 ) then if ( kprint == 2 ) then write (LUN, '('' SDRIV1:An invalid parameter has been correctly detected.'' //)') else if ( kprint == 3 ) then write (LUN, '('' SDRIV1: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, '('' SDRIV1:An invalid parameter has not been correctly detected.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' SDRIV1: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 SDRIV2 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 SDRIV2 (N, T, Y, SDF, TOUT, MSTATE, NROOT, EPS, EWT, & MINT, WORK, LENW, IWORK, LENIW, SDF, IERFLG) NSTEP = IWORK(3) NFE = IWORK(4) NJE = IWORK(5) if ( MSTATE == 2 ) then if ( ABS(1.E0 - Y(1)*1.5E0) <= EPS**(2.E0/3.E0) .and. & ABS(1.E0 - Y(2)*3.E0) <= EPS**(2.E0/3.E0) .and. & ABS(1.E0 - Y(3)) <= EPS**(2.E0/3.E0) ) then if ( kprint == 2 ) then write (LUN, '('' SDRIV2:The solution determined met the expected values.'' //)') else if ( kprint == 3 ) then write (LUN, '('' SDRIV2: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, '('' SDRIV2:The solution determined is not accurate enough.'' //)') else if ( kprint == 2 ) then write (LUN, '('' SDRIV2: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 SDRIV2, a solution was not obtained.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' While using SDRIV2, 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 SDRIV2 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 SDRIV2 (N, T, Y, SDF, TOUT, MSTATE, NROOT, EPS, EWT, & MINT, WORK, LENWX, IWORK, LENIW, SDF, IERFLG) if ( IERFLG == 32 ) then if ( kprint == 2 ) then write (LUN, '('' SDRIV2:An invalid parameter has been correctly detected.'' //)') else if ( kprint == 3 ) then write (LUN, '('' SDRIV2: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, '('' SDRIV2:An invalid parameter has not been correctly detected.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' SDRIV2: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 SDRIV3 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 SDRIV3 (N, T, Y, SDF, NSTATE, TOUT, NTASK, NROOT, EPS, EWT, & IERROR, MINT, MITER, IMPL, ML, MU, MXORD, HMAX, & WORK, LENW, IWORK, LENIW, SDF, SDF, NDE, & MXSTEP, SDF, SDF, IERFLG) NSTEP = IWORK(3) NFE = IWORK(4) NJE = IWORK(5) if ( NSTATE == 2 ) then if ( ABS(1.E0 - Y(1)*1.5E0) <= EPS**(2.E0/3.E0) .and. & ABS(1.E0 - Y(2)*3.E0) <= EPS**(2.E0/3.E0) .and. & ABS(1.E0 - Y(3)) <= EPS**(2.E0/3.E0) ) then if ( kprint == 2 ) then write (LUN, '('' SDRIV3:The solution determined met the expected values.'' //)') else if ( kprint == 3 ) then write (LUN, '('' SDRIV3: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, '('' SDRIV3:The solution determined is not accurate enough.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' SDRIV3: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 SDRIV3, a solution was not obtained.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' While using SDRIV3, 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 SDRIV3 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 SDRIV3 (N, T, Y, SDF, NSTATE, TOUT, NTASK, NROOT, EPS, & EWT, IERROR, MINT, MITER, IMPL, ML, MU, & MXORD, HMAX, WORK, LENW, IWORK, LENIWX, SDF, & SDF, NDE, MXSTEP, SDF, SDF, IERFLG) if ( IERFLG == 33 ) then if ( kprint == 2 ) then write (LUN, '('' SDRIV3:An invalid parameter has been correctly detected.'' //)') else if ( kprint == 3 ) then write (LUN, '('' SDRIV3: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, '('' SDRIV3:An invalid parameter has not been correctly detected.'' //)') else if ( kprint >= 2 ) then write (LUN, '('' SDRIV3: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 !! SDRES1 !***SUBSIDIARY !***PURPOSE First residual evaluator for SDASQC. !***LIBRARY SLATEC (DASSL) !***TYPE SINGLE PRECISION (SDRES1-S, DDRES1-D) !***AUTHOR PETZOLD, LINDA R., (LLNL) !***SEE ALSO SDASQC !***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 SDRES1 subroutine SDRES1 (T, Y, YPRIME, DELTA, IRES, RPAR, IPAR) integer IRES, IPAR(*) !***FIRST EXECUTABLE STATEMENT SDRES1 REAL T, Y(*), YPRIME(*), DELTA(*), RPAR(*) DELTA(1) = YPRIME(1) + 10.0E0*Y(1) DELTA(2) = Y(2) + Y(1) - 1.0E0 return end !! SDRES2 !***SUBSIDIARY !***PURPOSE Second residual evaluator for SDASQC. !***LIBRARY SLATEC (DASSL) !***TYPE SINGLE PRECISION (SDRES2-S, DDRES2-D) !***AUTHOR PETZOLD, LINDA R., (LLNL) !***SEE ALSO SDASQC !***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 SDRES2 subroutine SDRES2 (T, Y, YPRIME, DELTA, IRES, RPAR, IPAR) integer IRES, IPAR(*) REAL T, Y(*), YPRIME(*), DELTA(*), RPAR(*) integer I, J, K, NG REAL ALPH1, ALPH2, D !***FIRST EXECUTABLE STATEMENT SDRES2 DATA ALPH1/1.0E0/, ALPH2/1.0E0/, NG/5/ DO 10 J = 1,NG DO 10 I = 1,NG K = I + (J - 1)*NG D = -2.0E0*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 !! SFNCK !***PURPOSE Quick check for the single 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 single 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 ACOSH, AI, AIE, ALI, ALNREL, ASINH, ATANH, BESI0, ! BESI0E, BESI1, BESI1E, BESJ0, BESJ1, BESK0, BESK0E, ! BESK1, BESK1E, BESKES, BESKS, BESY0, BESY1, BETA, ! BETAI, BI, BIE, BINOM, CBRT, CHU, COSDG, COT, DAWS, ! E1, EI, ERF, EXPREL, FAC, GAMI, GAMIC, GAMIT, ! GAMMA, GAMR, POCH, POCH1, PSI, R1MACH, R9ATN1, ! R9LN2R, SINDG, SPENC !***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 SFNCK subroutine SFNCK (LUN, KPRINT, IPASS) integer I, lun, kprint, ipass REAL R1MACH, & Y(105),V(105),ERRMAX,ERRTOL,ABSERR,RELERR, & BESI1,BESI1E,BESJ0,BESJ1,BESK0,BESK0E,BESK1,BESK1E, & BESY0,BESY1,BETA,BETAI,BI,BIE,BINOM,CBRT,CHU,COSDG,COT,DAWS, & E1,EI,ERF,EXPREL,FAC,GAMI,GAMIC,GAMIT,GAMMA,GAMR,POCH,POCH1, & PSI,R9ATN1,R9LN2R,SINDG,SPENC ! ! Correct values through different calculations are stored in V(*) ! EXTERNAL COT, ERF, GAMMA DATA V( 1) / .834451800000000000000000000000E+09/ DATA V( 2) / .225082957512000000000000000000E+13/ DATA V( 3) / .130767436800000000000000000000E+13/ DATA V( 4) / .822283865417792281772556288000E+34/ DATA V( 5) /-.200000000000000000000000000000E+01/ DATA V( 6) / .998340790000000000000000000000E+02/ DATA V( 7) / .866025403784438646763723170753E+00/ DATA V( 8) /-.707106781186547524400844362105E+00/ DATA V( 9) / .642092615934330703006419986594E+00/ DATA V( 10) /-.183048772171245191926801943897E+01/ DATA V( 11) /-.290819127993551070285950148310E+00/ DATA V( 12) /-.111606410275738687122866817478E+00/ DATA V( 13) / .500000000000000000000000000000E+00/ DATA V( 14) / .707106781186547524400844362105E+00/ DATA V( 15) / .137149838147233638243285631505E+00/ DATA V( 16) /-.100000050000033333358333416027E-05/ DATA V( 17) / .100125104231803398984880296644E+01/ DATA V( 18) / .995016625083194642609402280122E+00/ DATA V( 19) / .243720864865315055824104923715E+00/ DATA V( 20) / .193147180559945309417232121458E+00/ DATA V( 21) / .111112222233333444440000000000E+00/ DATA V( 22) / .314159265359000000000000000000E+01/ DATA V( 23) / .998340790000000000000000000000E-01/ DATA V( 24) /-.119476321700000000000000000000E+01/ DATA V( 25) /-.111112222233333444440000000000E+00/ DATA V( 26) / .264665241200000000000000000000E+01/ DATA V( 27) /-.378671043061087976727207184637E+00/ DATA V( 28) / .104516378011749278484458888919E+01/ DATA V( 29) / .559773594776160811746795939295E+00/ DATA V( 30) / .100019582406632651901909339800E+00/ DATA V( 31) / .454219904863173579920523812663E+00/ DATA V( 32) / .189511781635593675546652093433E+01/ DATA V( 33) / .582240526465012505902656320160E+00/ DATA V( 34) / .164493406684822643647241516665E+01/ DATA V( 35) / .886226925452758013649083741687E+00/ DATA V( 36) /-.314159265358979323846264338328E+01/ DATA V( 37) / .318309886183790671537767526733E+00/ DATA V( 38) / .882395720020380090550940262394E-06/ DATA V( 39) /-.282094791773878143474039725759E+00/ DATA V( 40) / .187500000000000000000000000000E+01/ DATA V( 41) / .513516668382050295584635612122E-01/ DATA V( 42) / .598750000000000000000000000000E+02/ DATA V( 43) / .157079632679489661923132169164E+01/ DATA V( 44) / .755006169037464042751871235437E-03/ DATA V( 45) / .422784335098467139393487909918E+00/ DATA V( 46) / .230300103429768637527259355045E+01/ DATA V( 47) / .999856618263723706885830759463E+00/ DATA V( 48) / .888290707183956735878281870759E+00/ DATA V( 49) / .135335283236612691893999494971E+00/ DATA V( 50) / .346930306295801456170933128256E-03/ DATA V( 51) / .786938680574733152792400930048E+00/ DATA V( 52) / .631673391775258123291222663623E-01/ DATA V( 53) / .381281566461770916149261183171E+00/ DATA V( 54) / .265625000000000000000000000000E+00/ DATA V( 55) / .520499877813046537682746653770E+00/ DATA V( 56) / .888388231701707764069578446749E+00/ DATA V( 57) / .424436383502022295934042352455E+00/ DATA V( 58) / .337000659742093423383019719632E+00/ DATA V( 59) /-.177596771314338304347397013056E+00/ DATA V( 60) / .223890779141235668051827454628E+00/ DATA V( 61) /-.327579137591465222037734321812E+00/ DATA V( 62) / .576724807756873387202448242187E+00/ DATA V( 63) / .510375672649745119596606592612E+00/ DATA V( 64) /-.308517625249033780073648984210E+00/ DATA V( 65) / .147863143391226844801050675510E+00/ DATA V( 66) /-.107032431540937546888370772230E+00/ DATA V( 67) / .227958530233606726743720444020E+01/ DATA V( 68) / .272398718236044468945442320700E+02/ DATA V( 69) / .159063685463732906338225442450E+01/ DATA V( 70) / .243356421424505271991430504400E+02/ DATA V( 71) / .113893872749533435652719574910E+00/ DATA V( 72) / .369109833404259427473526100740E-02/ DATA V( 73) / .139865881816522427284598806997E+00/ DATA V( 74) / .404461344545216420836502183700E-02/ DATA V( 75) / .308508322553671039533384319255E+00/ DATA V( 76) / .183540812609328353073650751820E+00/ DATA V( 77) / .163972266944542356926122903850E+00/ DATA V( 78) / .215269289248937659158505143243E+00/ DATA V( 79) / .841568215070771417919124867127E+00/ DATA V( 80) / .547807564313518986868201568700E+00/ DATA V( 81) / .600273858788312582936045656600E+00/ DATA V( 82) / .103347684706868857317535710603E+01/ DATA V( 83) / .886226925452758013649083741000E+00/ DATA V( 84) / .132934038817913702047362561200E+01/ DATA V( 85) / .288023750772146354435952215970E+01/ DATA V( 86) / .560499121639792869931128243359E+00/ DATA V( 87) / .672598945967751443917353892000E+00/ DATA V( 88) / .964058489220443736281540578570E+00/ DATA V( 89) / .461068504447894558439575873876E+00/ DATA V( 90) / .922137008895789116879151747751E+00/ DATA V( 91) / .231693606480833489769125254500E+00/ DATA V( 92) / .157259233804704899952660465400E-01/ DATA V( 93) / .293277159129947362450897433147E+00/ DATA V( 94) / .219322205128712060862850888400E+00/ DATA V( 95) / .854277043103155493300048798776E+00/ DATA V( 96) / .187894150374789500090933504950E+01/ DATA V( 97) / .674892411115630212865414309867E+00/ DATA V( 98) / .464750480196092515019775411670E+00/ DATA V( 99) / .249999999999999999999999999880E+00/ DATA V(100) / .735008609300377745369706799000E+00/ DATA V(101) / .406961787650672979742685260000E+00/ DATA V(102) / .448256669291582953916931735480E+00/ DATA V(103) / .596347362323194074341078499290E+00/ DATA V(104) / .757342086122175953454414369190E+00/ !***FIRST EXECUTABLE STATEMENT SFNCK ! ! Exercise routines in Category C1. ! DATA V(105) / .757872156141312106043351240000E+00/ Y( 1) = BINOM(35,12) Y( 2) = BINOM(50,15) Y( 3) = FAC(15) ! ! Exercise routines in Category C2 ! Y( 4) = FAC(31) Y( 5) = CBRT(-8.E0) ! ! Exercise routines in Category C4A. ! Y( 6) = CBRT(.995030624365703964475039000000E6) Y( 7) = COSDG(30.E0) Y( 8) = COSDG(135.E0) Y( 9) = COT(1.E0) Y( 10) = COT(-.5E0) Y( 11) = R9ATN1(.5E0) Y( 12) = R9ATN1(2.E0) Y( 13) = SINDG(30.E0) ! ! Exercise routines in Category C4B. ! Y( 14) = SINDG(135.E0) Y( 15) = ALNREL(.147E0) Y( 16) = ALNREL(-.1E-5) Y( 17) = EXPREL(.25E-2) Y( 18) = EXPREL(-.1E-1) Y( 19) = R9LN2R(.5E0) ! ! Exercise routines in Category C4C. ! Y( 20) = R9LN2R(1.E0) Y( 21) = ACOSH(.100617931649094823747218929626E1) Y( 22) = ACOSH(.115919532755239084628557897777E2) Y( 23) = ASINH(.100000000101295145211538706587E0) Y( 24) = ASINH(-.149999999948240634124264852207E1) Y( 25) = ATANH(-.110657208041383998066515207788E0) ! ! Exercise routines in Category C5. ! Y( 26) = ATANH(.989999999992791300663084082410E0) Y( 27) = ALI(.5E0) Y( 28) = ALI(2.E0) Y( 29) = E1(.5E0) Y( 30) = E1(1.5E0) Y( 31) = EI(.5E0) Y( 32) = EI(1.E0) Y( 33) = SPENC(.5E0) Y( 34) = SPENC(1.E0) Y( 35) = GAMMA(1.5E0) Y( 36) = GAMMA(-.5E0)*GAMMA(1.5E0) Y( 37) = GAMR(-1.5E0)*GAMR(2.5E0) ! ! Exercise routines in Category C7A. ! Y( 38) = GAMR(10.5E0) Y( 39) = POCH(-.5E0,1.5E0) Y( 40) = POCH(.5E0,3.E0) Y( 41) = POCH1(.5E0,2.5E0) ! ! Exercise routines in Category C7B. ! Y( 42) = POCH1(10.5E0,2.E0) Y( 43) = BETA(.5E0,1.5E0) ! ! Exercise routines in Category C7C. ! Y( 44) = BETA(5.5E0,5.5E0) Y( 45) = PSI(2.E0) ! ! Exercise routines in Category C7E. ! Y( 46) = PSI(10.5E0) Y( 47) = GAMI(1.E0,8.85E0) Y( 48) = GAMI(2.E0,3.75E0) Y( 49) = GAMIC(1.E0,2.E0) Y( 50) = GAMIC(2.E0,10.4E0) Y( 51) = GAMIT(1.E0,.5E0) ! ! Exercise routines in Category C7F. ! Y( 52) = GAMIT(2.E0,3.75E0) Y( 53) = BETAI(.5E0,2.E0,1.5E0) ! ! Exercise routines in Category C8A. ! Y( 54) = BETAI(.25E0,1.5E0,2.E0) Y( 55) = ERF(.5E0) ! ! Exercise routines in Category C8C. ! Y( 56) = ERF(1.125E0) Y( 57) = DAWS(.5E0) ! ! Exercise routines in Category C10A1. ! Y( 58) = DAWS(1.84E0) Y( 59) = BESJ0(5.E0) Y( 60) = BESJ0(2.E0) Y( 61) = BESJ1(5.E0) Y( 62) = BESJ1(2.E0) Y( 63) = BESY0(2.E0) Y( 64) = BESY0(5.E0) Y( 65) = BESY1(5.E0) ! ! Exercise routines in Category C10B1. ! Y( 66) = BESY1(2.E0) Y( 67) = BESI0(2.E0) Y( 68) = BESI0(5.E0) Y( 69) = BESI1(2.E0) Y( 70) = BESI1(5.E0) Y( 71) = BESK0(2.E0) Y( 72) = BESK0(5.E0) Y( 73) = BESK1(2.E0) Y( 74) = BESK1(5.E0) Y( 75) = BESI0E(2.E0) Y( 76) = BESI0E(5.E0) Y( 77) = BESI1E(5.E0) Y( 78) = BESI1E(2.E0) Y( 79) = BESK0E(2.E0) Y( 80) = BESK0E(5.E0) Y( 81) = BESK1E(5.E0) ! ! Exercise routines in Category C10B3. ! Y( 82) = BESK1E(2.E0) call BESKES(.5E0,2.E0,3,Y(83)) call BESKES(.5E0,5.E0,3,Y(86)) ! ! Exercise routines in Category C10D. ! call BESKS(.5E0,1.E0,2,Y(89)) Y( 91) = AI(.5E0) Y( 92) = AI(2.5E0) Y( 93) = AIE(.5E0) Y( 94) = AIE(2.5E0) Y( 95) = BI(.5E0) Y( 96) = BI(1.5E0) Y( 97) = BIE(.5E0) ! ! Exercise routines in Category C11. ! Y( 98) = BIE(2.5E0) Y( 99) = CHU(1.E0,2.E0,4.E0) Y(100) = CHU(5.E0/6.E0,5.E0/3.E0,4.E0/3.E0) Y(101) = CHU(.75E0,.75E0,2.5E0) Y(102) = CHU(1.E0,1.E0,1.5E0) Y(103) = CHU(1.E0,1.E0,1.E0) Y(104) = CHU(1.E0,1.E0,-LOG(.5E0)) ! ! Check for possible errors ! Y(105) = CHU(.5E0,.5E0,1.E0) ERRMAX = R1MACH(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 (' Single precision Fullerton special function ', & ' routines o.k.') 620 FORMAT (' For I = ', I3, ' test fails with RELERR = ', & E38.30, ' and ABSERR = ', E38.30) end !! SGEQC !***PURPOSE Quick check for SGEFS and SGEIR. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SGEQC-S, DGEQC-D, CGEQC-C) !***KEYWORDS QUICK CHECK !***AUTHOR Jacobsen, Nancy, (LANL) !***DESCRIPTION ! ! Let A*X=B be a SINGLE 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 R1MACH, SGEFS, SGEIR !***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 SGEQC ! .. Scalar Arguments .. subroutine SGEQC (LUN, KPRINT, NERR) ! .. Local Scalars .. integer KPRINT, LUN, NERR REAL ERRCMP, ERRMAX ! .. Local Arrays .. integer I, IND, ITASK, J, KPROG, LDA, N REAL A(5,4), ATEMP(5,4), B(4), BTEMP(4), BXEX(4), WORK(20) integer IWORK(4) ! .. External Functions .. CHARACTER LIST(2)*4 REAL R1MACH ! .. External Subroutines .. EXTERNAL R1MACH ! .. Intrinsic Functions .. EXTERNAL SGEFS, SGEIR ! .. Data statements .. INTRINSIC ABS, MAX DATA A /5.0E0, 1.0E0, 0.3E0, 2.1E0, 0.0E0, & -1.0E0, -0.5E0, 1.0E0, 1.0E0, 0.0E0, & 4.5E0, -1.0E0, -1.7E0, 2.0E0, 0.0E0, & 0.5E0, 2.0E0, 0.6E0, 1.3E0, 0.0E0/ DATA B /0.0E0, 3.5E0, 3.6E0, 2.4E0/ DATA BXEX /0.10E+01, 0.10E+01, -0.10E+01, 0.10E+01/ !***FIRST EXECUTABLE STATEMENT SGEQC DATA LIST /'GEFS', 'GEIR'/ N = 4 LDA = 5 NERR = 0 ERRCMP = R1MACH(4)**0.8E0 ! if ( kprint >= 2) write (LUN,9000) ! ! First test case - normal ! DO 180 KPROG=1,2 ITASK = 1 DO 100 I=1,N BTEMP(I) = B(I) 100 continue 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 SGEFS (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) else call SGEIR (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) end if if ( IND < 0 ) then if ( kprint >= 2) write (LUN, FMT=9010) LIST(KPROG), IND NERR = NERR + 1 ! ! Calculate error for first test ! end if ! ERRMAX = 0.0E0 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.0E0 170 continue if ( KPROG == 1 ) then call SGEFS (ATEMP, LDA, N, BTEMP, ITASK, IND, WORK, IWORK) else call SGEIR (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, 'SGEFS and SGEIR Quick Check' /) 9010 FORMAT (/, 5X, 'S', A, ' Normal test PASSED') 9020 FORMAT (/, 5X, 'S', A, ' Test FAILED, MAX ABS(ERROR) is', E13.5) 9030 FORMAT (/, 5X, 'S', A, ' Singular test PASSED') 9040 FORMAT (/, 5X, 'S', A, ' Singular test FAILED, IND=', I3) 9050 FORMAT (/, 2X, 'SGEFS and SGEIR Quick Check PASSED' /) 9060 FORMAT (/, 2X, 'SGEFS and SGEIR Quick Check FAILED' /) end !! SLAPQC !***PURPOSE Quick check for testing Sparse Linear Algebra Package ! (SLAP) Version 2.0.2. !***LIBRARY SLATEC (SLAP) !***CATEGORY D2A4, D2B4 !***TYPE SINGLE 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 ! SRMGEN) 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 OUTERR, R1MACH, SCPPLT, SRMGEN, SS2Y, ! SSDBCG, SSDCG, SSDCGN, SSDCGS, SSDGMR, SSDOMN, ! SSGS, SSICCG, SSILUR, SSJAC, SSLUBC, SSLUCN, ! SSLUCS, SSLUGM, SSLUOM, VFILL, XERMAX, XSETF, ! XSETUN !***COMMON BLOCKS SSLBLK !***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 SSLBLK. (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 Added 1P's to output formats. (FNF) !***END PROLOGUE SLAPQC ! ! 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 SLAPQC (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 .. REAL SOLN(MAXN) REAL DENS, ERR, FACTOR, TOL integer IERR, ISYM, ITER, ITMAX, ITOL, ITOLGM, IUNIT, K, KASE, & ! .. Local Arrays .. LENIW, LENW, N, NELT, NELTMX, nfail, NMAX, NSAVE REAL A(MXNELT), F(MAXN), RWORK(MAXRW), XITER(MAXN) ! .. External Functions .. integer IA(MXNELT), IWORK(MAXIW), JA(MXNELT) REAL R1MACH ! .. External Subroutines .. EXTERNAL R1MACH EXTERNAL OUTERR, SCPPLT, SRMGEN, SS2Y, SSDBCG, SSDCG, SSDCGN, & SSDCGS, SSDGMR, SSDOMN, SSGS, SSICCG, SSILUR, SSJAC, & ! .. Intrinsic Functions .. SSLUBC, SSLUCN, SSLUCS, SSLUGM, SSLUOM, VFILL ! .. Common blocks .. INTRINSIC MAX, REAL ! ! The following lines are for the braindamaged Sun FPE handler. ! !$$$ integer oldmode, fpmode !***FIRST EXECUTABLE STATEMENT SLAPQC !$$$ oldmode = fpmode( 62464 ) ! ! Maximum problem sizes. ! COMMON /SSLBLK/ 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.2E0 if ( kprint < 3 ) then IUNIT = 0 else IUNIT = LUN ! ! Set the Error tolerance to depend on the machine epsilon. ! end if TOL = max ( 1.0E3*R1MACH(3),1.0E-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 SRMGEN( 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 SS2Y( N, NELT, IA, JA, A, ISYM ) if ( KPRINT >= 4 ) then write (LUN,1040) (K,IA(K),JA(K),A(K),K=1,NELT) call SCPPLT( N, NELT, IA, JA, A, ISYM, LUN ) ! !********************************************************************** ! BEGINNING OF SLAP QUICK TESTS !********************************************************************** ! ! * * * * * * SSJAC * * * * * * ! end if if ( KPRINT >= 3 ) then write (LUN,1000) 'SSJAC ', ITOL, ISYM end if ! call VFILL( N, XITER, 0.0E0 ) call SSJAC(N, F, XITER, NELT, IA, JA, A, ISYM, & ITOL, TOL, 2*ITMAX, ITER, ERR, IERR, IUNIT, & ! RWORK, LENW, IWORK, LENIW ) ! ! * * * * * SSGS * * * * * ! call OUTERR( 'SSJAC ',IERR,KPRINT,nfail,LUN,ITER,ERR ) if ( KPRINT >= 3 ) then write (LUN,1000) 'SSGS ',ITOL,ISYM end if ! call VFILL( N, XITER, 0.0E0 ) call SSGS(N, F, XITER, NELT, IA, JA, A, ISYM, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & ! RWORK, LENW, IWORK, LENIW ) ! ! * * * * * * SSILUR * * * * * * ! call OUTERR( 'SSGS ',IERR,KPRINT,nfail,LUN,ITER,ERR ) if ( KPRINT >= 3 ) then write (LUN,1000) 'SSILUR',ITOL,ISYM end if ! call VFILL( N, XITER, 0.0E0 ) call SSILUR(N, F, XITER, NELT, IA, JA, A, ISYM, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & ! RWORK, LENW, IWORK, LENIW ) ! ! * * * * * * SSDCG * * * * * * ! call OUTERR( 'SSILUR',IERR,KPRINT,nfail,LUN,ITER,ERR ) if ( ISYM == 1 ) then if ( KPRINT >= 3 ) then write (LUN,1000) 'SSDCG',ITOL,ISYM end if ! call VFILL( N, XITER, 0.0E0 ) call SSDCG(N, F, XITER, NELT, IA, JA, A, ISYM, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & ! RWORK, LENW, IWORK, LENIW ) call OUTERR( 'SSDCG ',IERR,KPRINT,nfail,LUN,ITER,ERR ) ! ! * * * * * * SSICCG * * * * * * ! end if if ( ISYM == 1 ) then if ( KPRINT >= 3 ) then write (LUN,1000) 'SSICCG',ITOL,ISYM end if ! call VFILL( N, XITER, 0.0E0 ) call SSICCG(N, F, XITER, NELT, IA, JA, A, ISYM, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, & ! LENW, IWORK, LENIW ) call OUTERR( 'SSICCG',IERR,KPRINT,nfail,LUN,ITER,ERR ) ! ! * * * * * * SSDCGN * * * * * * ! end if if ( KPRINT >= 3 ) then write (LUN,1000) 'SSDCGN',ITOL,ISYM end if ! call VFILL( N, XITER, 0.0E0 ) call SSDCGN(N, F, XITER, NELT, IA, JA, A, ISYM, ITOL, & TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, & ! IWORK, LENIW ) ! ! * * * * * * SSLUCN * * * * * * ! call OUTERR( 'SSDCGN',IERR,KPRINT,nfail,LUN,ITER,ERR ) if ( KPRINT >= 3 ) then write (LUN,1000) 'SSLUCN',ITOL,ISYM end if ! call VFILL( N, XITER, 0.0E0 ) call SSLUCN(N, F, XITER, NELT, IA, JA, A, ISYM, ITOL, & TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, & ! IWORK, LENIW ) ! ! * * * * * * SSDBCG * * * * * * ! call OUTERR( 'SSLUCN',IERR,KPRINT,nfail,LUN,ITER,ERR ) if ( KPRINT >= 3 ) then write (LUN,1000) 'SSDBCG',ITOL,ISYM end if ! call VFILL( N, XITER, 0.0E0 ) call SSDBCG(N, F, XITER, NELT, IA, JA, A, ISYM, ITOL, & TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, & ! IWORK, LENIW ) ! ! * * * * * * SSLUBC * * * * * * ! call OUTERR( 'SSDBCG',IERR,KPRINT,nfail,LUN,ITER,ERR ) if ( KPRINT >= 3 ) then write (LUN,1000) 'SSLUBC',ITOL,ISYM end if ! call VFILL( N, XITER, 0.0E0 ) call SSLUBC(N, F, XITER, NELT, IA, JA, A, ISYM, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & ! RWORK, LENW, IWORK, LENIW ) ! ! * * * * * * SSDCGS * * * * * * ! call OUTERR( 'SSLUBC',IERR,KPRINT,nfail,LUN,ITER,ERR ) if ( KPRINT >= 3 ) then write (LUN,1000) 'SSDCGS',ITOL,ISYM end if ! call VFILL( N, XITER, 0.0E0 ) call SSDCGS(N, F, XITER, NELT, IA, JA, A, ISYM, ITOL, & TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, & ! IWORK, LENIW ) ! ! * * * * * * SSLUCS * * * * * * ! call OUTERR( 'SSDCGS',IERR,KPRINT,nfail,LUN,ITER,ERR ) if ( KPRINT >= 3 ) then write (LUN,1000) 'SSLUCS',ITOL,ISYM end if ! call VFILL( N, XITER, 0.0E0 ) call SSLUCS(N, F, XITER, NELT, IA, JA, A, ISYM, & ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, & ! RWORK, LENW, IWORK, LENIW ) ! ! * * * * * * SSDOMN * * * * * * ! !VD$ NOVECTOR call OUTERR( 'SSLUCS',IERR,KPRINT,nfail,LUN,ITER,ERR ) DO 30 NSAVE = 0, 3 if ( KPRINT >= 3 ) then write (LUN,1010) 'SSDOMN',ITOL, ISYM, NSAVE end if ! call VFILL( N, XITER, 0.0E0 ) call SSDOMN(N, F, XITER, NELT, IA, JA, A, & ISYM, NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, & ! IUNIT, RWORK, LENW, IWORK, LENIW ) call OUTERR( 'SSDOMN',IERR,KPRINT,nfail,LUN,ITER,ERR ) ! ! * * * * * * SSLUOM * * * * * * ! !VD$ NOVECTOR 30 continue DO 40 NSAVE=0,3 if ( KPRINT >= 3 ) then write (LUN,1010) 'SSLUOM',ITOL, ISYM, NSAVE end if ! call VFILL( N, XITER, 0.0E0 ) call SSLUOM(N, F, XITER, NELT, IA, JA, A, & ISYM, NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, & ! IUNIT, RWORK, LENW, IWORK, LENIW ) call OUTERR( 'SSLUOM',IERR,KPRINT,nfail,LUN,ITER,ERR ) ! ! * * * * * * SSDGMR * * * * * * ! !VD$ NOVECTOR 40 continue DO 50 NSAVE = 5, 12 if ( KPRINT >= 3 ) then write (LUN,1010) 'SSDGMR',ITOL, ISYM, NSAVE end if call VFILL( N, XITER, 0.0E0 ) ! ITOLGM = 0 call SSDGMR(N, F, XITER, NELT, IA, JA, A, & ISYM, NSAVE, ITOLGM, TOL, ITMAX, ITER, ERR, IERR, & ! IUNIT, RWORK, LENW, IWORK, LENIW ) call OUTERR( 'SSDGMR',IERR,KPRINT,nfail,LUN,ITER,ERR ) ! ! * * * * * * SSLUGM * * * * * * ! !VD$ NOVECTOR 50 continue DO 60 NSAVE = 5, 12 if ( KPRINT >= 3 ) then write (LUN,1010) 'SSLUGM',ITOL, ISYM, NSAVE end if ! call VFILL( N, XITER, 0.0E0 ) call SSLUGM(N, F, XITER, NELT, IA, JA, A, & ISYM, NSAVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, & ! IUNIT, RWORK, LENW, IWORK, LENIW ) call OUTERR( 'SSLUGM',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, 'SLAPQC -- 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,E16.7) 1030 FORMAT(' Error tolerance = ',1P,E16.7) 1040 FORMAT(/' ***** SLAP Column Matrix *****'/ & ' Indx ia ja a'/(1X,I4,1X,I4,1X,I4,1X,1P,E16.7)) 1050 FORMAT('1'/' Running tests with N =',I3,', KASE =',I2, & ', ISYM =',I2) 5001 FORMAT('--------- All single precision SLAP tests passed ', & '---------') 5002 FORMAT('*********',I3,' single precision SLAP tests failed ', & '*********') end subroutine SMAKE2 (TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL, & !! SMAKE2 !***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 SBEG !***REVISION HISTORY (YYMMDD) ! 870810 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE SMAKE2 ! .. Parameters .. KU, RESET, TRANSL) REAL ZERO, ONE PARAMETER ( ZERO = 0.0, ONE = 1.0 ) REAL ROGUE ! .. Scalar Arguments .. PARAMETER ( ROGUE = -1.0E10 ) REAL TRANSL integer KL, KU, LDA, M, N, NMAX LOGICAL RESET CHARACTER*1 DIAG, UPLO ! .. Array Arguments .. CHARACTER*2 TYPE ! .. Local Scalars .. REAL A( NMAX, * ), AA( * ) integer I, I1, I2, I3, IBEG, IEND, IOFF, J, KK ! .. External Functions .. LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER REAL SBEG ! .. Intrinsic Functions .. EXTERNAL SBEG !***FIRST EXECUTABLE STATEMENT SMAKE2 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 ) = SBEG( 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 ) & 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 == '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 100 I = 1, IBEG - 1 AA( I + ( J - 1 )*LDA ) = ROGUE 100 continue 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 160 I = IEND + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 160 continue 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 ! ! End of SMAKE2. ! return end subroutine SMAKE3 (TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, & !! SMAKE3 !***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 SBEG !***REVISION HISTORY (YYMMDD) ! 890208 DATE WRITTEN ! 910620 Modified to meet SLATEC code and prologue standards. (BKS) !***END PROLOGUE SMAKE3 ! .. Parameters .. RESET, TRANSL) REAL ZERO, ONE PARAMETER ( ZERO = 0.0, ONE = 1.0 ) REAL ROGUE ! .. Scalar Arguments .. PARAMETER ( ROGUE = -1.0E10 ) REAL TRANSL integer LDA, M, N, NMAX LOGICAL RESET CHARACTER*1 DIAG, UPLO ! .. Array Arguments .. CHARACTER*2 TYPE ! .. Local Scalars .. REAL A( NMAX, * ), AA( * ) integer I, IBEG, IEND, J ! .. External Functions .. LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER REAL SBEG !***FIRST EXECUTABLE STATEMENT SMAKE3 EXTERNAL SBEG 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 ) = SBEG( 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 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 90 continue end if ! ! End of SMAKE3. ! return end subroutine SMMCH (TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, & !! SMMCH !***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 SMMCH ! .. Parameters .. BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FTL, NOUT, MV, KPRINT) REAL ZERO, ONE ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0, ONE = 1.0 ) REAL ALPHA, BETA, EPS, ERR integer KK, KPRINT, LDA, LDB, LDC, LDCC, M, N, NOUT LOGICAL MV, FTL ! .. Array Arguments .. CHARACTER*1 TRANSA, TRANSB REAL A( LDA, * ), B( LDB, * ), C( LDC, * ), & ! .. Local Scalars .. CC( LDCC, * ), CT( * ), G( * ) REAL ERRI integer I, J, K ! .. Intrinsic Functions .. LOGICAL TRANA, TRANB !***FIRST EXECUTABLE STATEMENT SMMCH 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 90 K = 1, KK DO 80 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 ) ) 80 continue 90 continue 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' ) ! ! End of SMMCH. ! 9998 FORMAT( 1X, I7, 2G18.6 ) end subroutine SMVCH (TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y, & !! SMVCH !***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 SMVCH ! .. Parameters .. INCY, YT, G, YY, EPS, ERR, FTL, NOUT, MV, KPRINT) REAL ZERO, ONE ! .. Scalar Arguments .. PARAMETER ( ZERO = 0.0, ONE = 1.0 ) REAL ALPHA, BETA, EPS, ERR integer INCX, INCY, KPRINT, M, N, NMAX, NOUT LOGICAL MV, FTL ! .. Array Arguments .. CHARACTER*1 TRANS REAL A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ), & ! .. Local Scalars .. YY( * ) REAL ERRI integer I, INCXL, INCYL, IY, J, JX, K, KX, KY, ML, NL ! .. Intrinsic Functions .. LOGICAL TRAN !***FIRST EXECUTABLE STATEMENT SMVCH 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 20 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 20 continue 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 60 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 60 continue 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 SMVCH. ! 9998 FORMAT( 1X, I7, 2G18.6 ) end !! SNLS1Q !***PURPOSE Quick check for SNLS1E, SNLS1 and SCOV. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SNLS1Q-S, DNLS1Q-D) !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine performs a quick check on the subroutines SNLS1E ! (and SNLS1) and SCOV. ! !***ROUTINES CALLED ENORM, FCN1, FCN2, FCN3, FDJAC3, PASS, R1MACH, ! SCOV, SNLS1E !***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 SNLS1Q ! .. Scalar Arguments .. subroutine SNLS1Q (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN REAL 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 REAL FJAC(10,2), FJROW(2), FJTJ(3), FVEC(10), WA(40), X(2) ! .. External Functions .. integer IW(2) REAL ENORM, R1MACH integer NUMXER ! .. External Subroutines .. EXTERNAL ENORM, NUMXER, R1MACH EXTERNAL FCN1, FCN2, FCN3, FDJAC3, PASS, SCOV, SNLS1E, XGETF, & ! .. Intrinsic Functions .. XSETF !***FIRST EXECUTABLE STATEMENT SNLS1Q INTRINSIC ABS, SQRT ! if ( kprint >= 2) write (LUN,9000) ipass = 1 INFOS = 1 FNORMS = 1.1151779E+01 M = 10 N = 2 LWA = 40 LDFJAC = 10 NPRINT = -1 IFLAG = 1 ZERO = 0.0E0 ONE = 1.0E0 TOL = SQRT(40.0E0*R1MACH(4)) ! ! OPTION=2, the full Jacobian is stored and the user provides the ! Jacobian. ! TOL2 = SQRT(TOL) IOPT = 2 X(1) = 3.0E-1 X(2) = 4.0E-1 call SNLS1E(FCN2,IOPT,M,N,X,FVEC,TOL,NPRINT,INFO,IW,WA,LWA) FNORM = ENORM(M,FVEC) if ( INFO == INFOS .and. ABS(FNORM-FNORMS)/FNORMS <= TOL ) 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 FCN2(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 SCOV(FCN2,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.0E-1 X(2) = 4.0E-1 call SNLS1E(FCN1,IOPT,M,N,X,FVEC,TOL,NPRINT,INFO,IW,WA,LWA) FNORM = ENORM(M,FVEC) if ( INFO == INFOS .and. ABS(FNORM-FNORMS)/FNORMS <= TOL ) 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 FDJAC3(FCN1,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 SCOV(FCN1,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.0E-1 X(2) = 4.0E-1 call SNLS1E(FCN3,IOPT,M,N,X,FVEC,TOL,NPRINT,INFO,IW,WA,LWA) FNORM = ENORM(M,FVEC) if ( INFO == INFOS .and. ABS(FNORM-FNORMS)/FNORMS <= TOL ) 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) DO 100 I = 1,3 FJTJ(I) = ZERO 100 continue IFLAG = 3 DO 110 I = 1,M call FCN3(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 SCOV(FCN3,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.0E-1 X(2) = 4.0E-1 call SNLS1E(FCN2,IOPT,M,N,X,FVEC,TOL,NPRINT,INFO,IW,WA,LWA) ! if ( INFO /= 0 .OR. NUMXER(NERR) /= 2) FATAL = .TRUE. M = 0 call SCOV(FCN2,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 SNLS1E, SNLS1 and SCOV') 9010 FORMAT (' EXPECTED VALUE OF INFO AND RESIDUAL NORM', I5, E20.9 / & ' RETURNED VALUE OF INFO AND RESIDUAL NORM', I5, E20.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)' / 3E20.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 (/' *************SNLS1E PASSED ALL TESTS*****************') 9110 FORMAT (/' ************SNLS1E FAILED SOME TESTS*****************') end !! SNSQQK !***PURPOSE Quick check for SNSQE and SNSQ. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SNSQQK-S, DNSQQK-D) !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! This subroutine performs a quick check on the subroutine SNSQE ! (and SNSQ). ! !***ROUTINES CALLED ENORM, PASS, R1MACH, SNSQE, SQFCN2, SQJAC2 !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891009 Removed unreferenced variable. (WRB) ! 891009 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 SNSQQK ! .. Scalar Arguments .. subroutine SNSQQK (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN REAL FNORM, FNORMS, TOL ! .. Local Arrays .. integer ICNT, INFO, INFOS, IOPT, LWA, N, NPRINT REAL FVEC(2), WA(19), X(2) ! .. External Functions .. integer ITEST(3) REAL ENORM, R1MACH ! .. External Subroutines .. EXTERNAL ENORM, R1MACH ! .. Intrinsic Functions .. EXTERNAL PASS, SNSQE, SQFCN2, SQJAC2 !***FIRST EXECUTABLE STATEMENT SNSQQK INTRINSIC SQRT INFOS = 1 FNORMS = 0.0E0 N = 2 LWA = 19 NPRINT = -1 TOL = SQRT(R1MACH(4)) ! ! Option 1, the user provides the Jacobian. ! if ( kprint >= 2) write (LUN,9000) IOPT = 1 X(1) = -1.2E0 X(2) = 1.0E0 call SNSQE (SQFCN2,SQJAC2,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA) ICNT = 1 FNORM = ENORM(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.2E0 X(2) = 1.0E0 call SNSQE (SQFCN2,SQJAC2,IOPT,N,X,FVEC,TOL,NPRINT,INFO,WA,LWA) ICNT = 2 FNORM = ENORM(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.2E0 X(2) = 1.0E0 call SNSQE (SQFCN2,SQJAC2,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' / ' SNSQE QUICK CHECK'/) 9010 FORMAT (' EXPECTED VALUE OF INFO AND RESIDUAL NORM', I5, E20.5 / & ' RETURNED VALUE OF INFO AND RESIDUAL NORM', I5, E20.5 /) 9020 FORMAT (/' **********WARNING -- SNSQE/SNSQ FAILED SOME TESTS****', & '******') 9030 FORMAT (/' ----------SNSQE/SNSQ PASSED ALL TESTS----------') end !! SOSFNC !***PURPOSE Function evaluator for SOS quick check. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! FUNCTION WHICH EVALUATES THE FUNCTIONS, ONE AT A TIME, ! FOR TEST PROGRAM USED IN QUICK CHECK OF SOS. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 801001 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE SOSFNC REAL FUNCTION SOSFNC (X, K) !***FIRST EXECUTABLE STATEMENT SOSFNC dimension X(2) if ( K == 1) SOSFNC=1.E0-X(1) if ( K == 2) SOSFNC=1.E1*(X(2)-X(1)**2) return end !! SOSNQX !***PURPOSE Quick check for SOS. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SOSNQX-S, DSOSQX-D) !***KEYWORDS QUICK CHECK !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! This subroutine performs a quick check on the subroutine SOS. ! !***ROUTINES CALLED PASS, R1MACH, SNRM2, SOS, SOSFNC !***REVISION HISTORY (YYMMDD) ! 801001 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 SOSNQX ! .. Scalar Arguments .. subroutine SOSNQX (LUN, KPRINT, IPASS) ! .. Local Scalars .. integer IPASS, KPRINT, LUN REAL AER, FNORM, FNORMS, RER, TOLF ! .. Local Arrays .. integer ICNT, IFLAG, IFLAGS, LIW, LWA, N REAL FVEC(2), WA(17), X(2) ! .. External Functions .. integer ITEST(2), IW(6) REAL R1MACH, SNRM2, SOSFNC ! .. External Subroutines .. EXTERNAL R1MACH, SNRM2, SOSFNC ! .. Intrinsic Functions .. EXTERNAL PASS, SOS !***FIRST EXECUTABLE STATEMENT SOSNQX INTRINSIC SQRT IFLAGS = 3 FNORMS = 0.0E0 N = 2 LWA = 17 LIW = 6 TOLF = SQRT(R1MACH(4)) RER = SQRT(R1MACH(4)) AER = 0.0E0 ! ! Test the code with proper input values. ! if ( kprint >= 2) write (LUN,9000) IFLAG = 0 X(1) = -1.2E0 X(2) = 1.0E0 call SOS (SOSFNC,N,X,RER,AER,TOLF,IFLAG,WA,LWA,IW,LIW) ICNT = 1 FVEC(1) = SOSFNC(X,1) FVEC(2) = SOSFNC(X,2) FNORM = SNRM2(N,FVEC,1) ITEST(ICNT) = 0 ! if ( IFLAG <= IFLAGS .and. FNORM-FNORMS <= RER) ITEST(ICNT) = 1 if ( kprint /= 0 ) then if ( KPRINT >= 3 .OR. (KPRINT>=2 .and. ITEST(ICNT) /= 1)) & write (LUN,9010) IFLAGS,FNORMS,IFLAG,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 IFLAG = 0 X(1) = -1.2E0 X(2) = 1.0E0 call SOS (SOSFNC,N,X,RER,AER,TOLF,IFLAG,WA,LWA,IW,LIW) ICNT = 2 ITEST(ICNT) = 0 if ( IFLAG == 9) 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) if ( KPRINT >= 1 .and. ipass /= 1) write (LUN,9020) if ( KPRINT >= 2 .and. ipass == 1) write (LUN,9030) return 9000 FORMAT ('1' / ' SOS QUICK CHECK' /) 9010 FORMAT (' EXPECTED VALUE OF IFLAG AND RESIDUAL NORM', I5, E20.5 / & ' RETURNED VALUE OF IFLAG AND RESIDUAL NORM', I5, E20.5 /) 9020 FORMAT (/' **********WARNING -- SOS FAILED SOME TESTS**********') 9030 FORMAT (/' ----------SOS PASSED ALL TESTS----------') end !! SPLPQX !***PURPOSE Quick check for SPLP. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SPLPQX-S, DPLPQX-D) !***AUTHOR (UNKNOWN) !***ROUTINES CALLED PASS, SCOPY, SPLP, USRMAT !***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 SPLPQX subroutine SPLPQX (LUN, KPRINT, IPASS) EXTERNAL USRMAT REAL COSTS(37) dimension PRGOPT(50), DATTRV(210), BL(60), BU(60) dimension IND(60), PRIMAL(60), DUALS(60), IBASIS(60) dimension WORK(800), IWORK(900), ISOLN(14) !***FIRST EXECUTABLE STATEMENT SPLPQX dimension D(14,37) if ( KPRINT >= 2) WRITE(LUN,999) 999 FORMAT ('1 SPLP QUICK CHECK') ICNT=1 ! ! DEFINE WORKING ARRAY LENGTHS ! ZERO = 0.0 LIW = 900 LW = 800 MRELAS = 14 ! ! DEFINE THE ARRAY COSTS(*) FOR THE OBJECTIVE FUNCTION ! NVARS = 37 COSTS(1) = 1.030 COSTS(2) = 0.985 COSTS(3) = 0.997 COSTS(4) = 1.036 COSTS(5) = 1.005 COSTS(6) = 0.980 COSTS(7) = 1.004 COSTS(8) = 0.993 COSTS(9) = 1.018 COSTS(10) = 0.947 COSTS(11) = 0.910 COSTS(12) = 1.028 COSTS(13) = 0.957 COSTS(14) = 1.025 COSTS(15) = 1.036 COSTS(16) = 1.060 COSTS(17) = 0.954 COSTS(18) = 0.891 COSTS(19) = 0.921 COSTS(20) = 1.040 COSTS(21) = 0.912 COSTS(22) = 0.926 COSTS(23) = 1.000 COSTS(24) = 0.000 COSTS(25) = 0.000 COSTS(26) = 0.000 COSTS(27) = 0.000 COSTS(28) = 0.000 COSTS(29) = 0.000 COSTS(30) = 0.000 COSTS(31) = 0.000 COSTS(32) = 0.000 COSTS(33) = 0.000 COSTS(34) = 0.000 COSTS(35) = 0.000 COSTS(36) = 0.000 ! ! PLACE THE NONZERO INFORMATION ABOUT THE MATRIX IN DATTRV(*) ! COSTS(37) = 0.000 call SCOPY(14*37, ZERO, 0, D, 1) D(1,1) = 1.04000 D(1,23) = 1.00000 D(1,24) = -1.00000 D(2,6) = 0.04125 D(2,7) = 0.05250 D(2,17) = 0.04875 D(2,24) = 1.00000 D(2,25) = -1.00000 D(3,8) = 0.05625 D(3,9) = 0.06875 D(3,11) = 0.02250 D(3,25) = 1.00000 D(3,26) = -1.00000 D(4,2) = 1.04000 D(4,3) = 1.05375 D(4,5) = 1.06125 D(4,12) = 0.08000 D(4,16) = 0.09375 D(4,18) = 0.03750 D(4,19) = 0.04625 D(4,20) = 0.08125 D(4,22) = 0.05250 D(4,26) = 1.00000 D(4,27) = -1.00000 D(5,10) = 0.04375 D(5,27) = 1.00000 D(5,28) = -1.00000 D(6,4) = 1.05875 D(6,13) = 0.04500 D(6,14) = 0.06375 D(6,15) = 0.06625 D(6,21) = 0.05000 D(6,28) = 1.00000 D(6,29) = -1.00000 D(7,6) = 1.04125 D(7,7) = 1.05250 D(7,8) = 1.05625 D(7,9) = 1.06875 D(7,11) = 0.02250 D(7,17) = 0.04875 D(7,29) = 1.00000 D(7,30) = -1.00000 D(8,10) = 1.04375 D(8,12) = 0.08000 D(8,13) = 0.04500 D(8,14) = 0.06375 D(8,15) = 0.06625 D(8,16) = 0.09375 D(8,18) = 0.03750 D(8,19) = 0.04625 D(8,20) = 0.08125 D(8,21) = 0.05000 D(8,22) = 0.05250 D(8,30) = 1.00000 D(8,31) = -1.00000 D(9,11) = 1.02250 D(9,17) = 0.04875 D(9,31) = 1.00000 D(9,32) = -1.00000 D(10,12) = 1.08000 D(10,13) = 1.04500 D(10,14) = 1.06375 D(10,15) = 1.06625 D(10,16) = 1.09375 D(10,18) = 0.03750 D(10,19) = 0.04625 D(10,20) = 0.08125 D(10,21) = 0.05000 D(10,22) = 0.05250 D(10,32) = 1.00000 D(10,33) = -1.00000 D(11,17) = 1.04875 D(11,33) = 1.00000 D(11,34) = -1.00000 D(12,18) = 1.03750 D(12,19) = 1.04625 D(12,20) = 1.08125 D(12,21) = 1.05000 D(12,22) = 0.05250 D(12,34) = 1.00000 D(12,35) = -1.00000 D(13,35) = 1.00000 D(13,36) = -1.00000 D(14,22) = 1.05250 D(14,36) = 1.00000 D(14,37) = -1.00000 KOUNT = 1 DO 20 MM=1,NVARS DATTRV(KOUNT) = -MM DO 10 KK=1,MRELAS if ( D(KK,MM) == ZERO) GO TO 10 KOUNT = KOUNT + 1 DATTRV(KOUNT) = KK KOUNT = KOUNT + 1 DATTRV(KOUNT) = D(KK,MM) 10 continue KOUNT = KOUNT + 1 20 continue ! ! NON-NEGATIVITY CONSTRAINT ! DATTRV(KOUNT) = ZERO DO 30 IC=1,NVARS BL(IC) = ZERO IND(IC) = 3 BU(IC) = 10000000.000 ! ! LE CONSTRAINTS ! 30 continue DO 40 IV=1,MRELAS IVV = IV + NVARS IND(IVV) = 3 BL(IVV) = 100.00000 BU(IVV) = 100000000.00000 40 continue 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 SPLP(USRMAT, MRELAS, NVARS, COSTS, PRGOPT, DATTRV, BL, BU, & ! ! LOOK FOR THE KNOWN BASIS AT THE SOLN., NOW IS ISOLN(*). ! IND, INFO, PRIMAL, DUALS, IBASIS, WORK, LW, IWORK, LIW) DO 50 I=1,MRELAS ISOLN(I) = PRGOPT(I+3) ! 50 continue ipass = 1 DO 70 J=1,MRELAS DO 60 I=1,MRELAS if ( ISOLN(I) == IBASIS(J)) GO TO 70 60 continue 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 (/' ************ SPLP PASSED ALL TESTS *****************') 99999 FORMAT (/' ************ SPLP FAILED SOME TESTS ****************') end !! SQCK !***PURPOSE Quick check for SPOFS, SPOIR, SNBFS and SNBIR. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR Voorhees, E. A., (LANL) !***DESCRIPTION ! ! QUICK CHECK SUBROUTINE SQCK TESTS THE EXECUTION OF THE ! SLATEC SUBROUTINES SPOFS, SPOIR, SNBFS AND SNBIR. ! 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. SQCK ! 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. SQCK ALSO ! TESTS ERROR HANDLING BY THE SUBROUTINE (CALLS TO ! XERMSG (SQCK SETS IFLAG/KONTRL TO 0)) ! USING A SINGULAR MATRIX FOR CASE 2. EACH EXECUTION ! PROBLEM DETECTED BY SQCK RESULTS IN AN ADDITIONAL ! EXPLANATORY LINE OF OUTPUT. ! ! SQCK REQUIRES NO INPUT ARGUMENTS. ! ON RETURN, NERR (INTEGER TYPE) CONTAINS THE TOTAL COUNT ! OF ALL PROBLEMS DETECTED BY SQCK. ! !***ROUTINES CALLED R1MACH, SNBFS, SNBIR, SPOFS, SPOIR !***REVISION HISTORY (YYMMDD) ! 800930 DATE WRITTEN ! 890911 Removed unnecessary intrinsics. (WRB) ! 891009 Removed unreferenced statement label. (WRB) ! 891009 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 901009 Routine writes illegal character to column 1, fixed. ! Editorial changes made, code fixed to test all four ! routines. (RWC) ! 901009 Restructured using IF-THEN-else-end if, cleaned up FORMATs, ! including removing an illegal character from column 1, and ! fixed code to test all four routines. (RWC) !***END PROLOGUE SQCK subroutine SQCK (LUN, KPRINT, NERR) REAL A(4,4),AT(5,4),ABE(5,7),ABET(5,7),B(4),BT(4),C(4),WORK(35), & R,DELX,DELMAX,SIGN,R1MACH CHARACTER*4 LIST(4) integer LDA,N,ML,MU,IND,IWORK(4),NERR,I,J,J1,J2,JD,MLP,K,KCASE, & KPROG DATA A/5.0E0,4.0E0,1.0E0,1.0E0,4.0E0,5.0E0,1.0E0,1.0E0, & 1.0E0,1.0E0,4.0E0,2.0E0,1.0E0,1.0E0,2.0E0,4.0E0/ !***FIRST EXECUTABLE STATEMENT SQCK 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 ! ! COMPUTE C VECTOR. ! R = R1MACH(4)**0.8E0 SIGN = 1.0E0 DO 10 I=1,N C(I) = SIGN/I SIGN = -SIGN ! ! CASE 1 FOR WELL-CONDITIONED MATRIX, CASE 2 FOR SINGULAR MATRIX. ! 10 continue DO 170 KCASE=1,2 ! SET VECTOR B TO ZERO. DO 140 KPROG=1,4 DO 11 I=1,N B(I) = 0.0E0 ! ! FORM VECTOR B FOR NON-BANDED. ! 11 continue if ( KPROG <= 2 ) 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 DO 30 J=1,JD DO 20 I=1,N ABE(I,J) = 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) B(I) = B(I)+(A(I,J)*C(J)) 40 continue 50 continue ! ! FORM BT FROM B, AT FROM A, AND ABET FROM ABE. ! end if 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 ! 88 continue DO 90 J=1,JD ABET(1,J) = 0.0E0 90 continue ! ! SOLVE FOR X ! end if if ( KPROG == 1) call SPOFS (AT,LDA,N,BT,1,IND,WORK) if ( KPROG == 2) call SPOIR (AT,LDA,N,BT,1,IND,WORK) if ( KPROG == 3) call SNBFS (ABET,LDA,N,ML,MU,BT,1,IND,WORK, & IWORK) if ( KPROG == 4) call SNBIR (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(BT(I)-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 (/' * SQCK - QUICK CHECK FOR SPOFS, SPOIR, SNBFS AND ', & 'SNBIR'/) 801 FORMAT (' PROBLEM WITH S', A, ', CASE ', I1, & '. MAX ABS ERROR OF', E11.4/) 802 FORMAT (' PROBLEM WITH S', A, ', CASE ', I1, '. IND = ', I2, & ' INSTEAD OF -4'/) 803 FORMAT (/' **** SQCK DETECTED A TOTAL OF ', I2,' PROBLEMS. ****'/) 804 FORMAT (' SQCK DETECTED NO PROBLEMS.'/) end !! SQFCN2 !***PURPOSE Evaluate function used in SNSQE. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (SQFCN2-S, DQFCN2-D) !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! Subroutine which evaluates the function for test program ! used in quick check of SNSQE. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 930214 TYPE and declarations sections added. (WRB) !***END PROLOGUE SQFCN2 ! .. Scalar Arguments .. subroutine SQFCN2 (N, X, FVEC, IFLAG) ! .. Array Arguments .. integer IFLAG, N !***FIRST EXECUTABLE STATEMENT SQFCN2 REAL FVEC(*), X(*) FVEC(1) = 1.0E0 - X(1) FVEC(2) = 10.0E0*(X(2)-X(1)**2) return end !! SQJAC2 !***PURPOSE Evaluate full Jacobian for SNSQE test. !***LIBRARY SLATEC !***KEYWORDS QUICK CHECK !***AUTHOR (UNKNOWN) !***DESCRIPTION ! ! SUBROUTINE TO EVALUATE THE FULL JACOBIAN FOR TEST PROBLEM USED ! IN QUICK CHECK OF SNSQE. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE SQJAC2 subroutine SQJAC2 (N, X, FVEC, FJAC, LDFJAC, IFLAG) !***FIRST EXECUTABLE STATEMENT SQJAC2 dimension X(*),FVEC(*),FJAC(LDFJAC,*) FJAC(1,1)=-1.E0 FJAC(1,2)=0.E0 FJAC(2,1)=-2.E1*X(1) FJAC(2,2)=1.E1 return end subroutine SRMGEN (NELTMX, FACTOR, IERR, N, NELT, ISYM, IA, JA, A, & !! SRMGEN !***SUBSIDIARY !***PURPOSE This routine generates a "Random" symmetric or ! non-symmetric matrix of size N for use in the SLAP ! Quick Checks. !***LIBRARY SLATEC (SLAP) !***TYPE SINGLE PRECISION (SRMGEN-S, DRMGEN-D) !***AUTHOR Seager, Mark K., (LLNL) ! seager@llnl.gov ! Lawrence Livermore National Laboratory ! PO BOX 808, L-300 ! Livermore, CA 94550 ! (510) 423-3141 !***DESCRIPTION ! ! *Usage: ! INTEGER NELTMX, IERR, N, NELT, ISYM, ! INTEGER IA(NELTMX), JA(NELTMX), ITMP(N), IDIAG(N) ! REAL FACTOR, A(NELTMX), F(N), SOLN(N), DSUM(N) ! ! call SRMGEN( NELTMX, FACTOR, IERR, N, NELT, ISYM, ! $ IA, JA, A, F, SOLN, DSUM, ITMP, IDIAG ) ! ! *Arguments: ! ! NELTMX :IN Integer. ! Maximum number of non-zeros that can be created by this ! routine for storage in the IA, JA, A arrays, see below. ! FACTOR :IN Real. ! Non-zeros in the upper triangle are set to FACTOR times ! the corresponding entry in the lower triangle when a non- ! symmetric matrix is requested (See ISYM, below). ! IERR :OUT Integer. ! Return error flag. ! IERR = 0 => everything went OK. ! = 1 => Ran out of space trying to create matrix. ! Set NELTMX to something larger and retry. ! N :IN Integer. ! Size of the linear system to generate (number of unknowns). ! NELT :OUT Integer. ! Number of non-zeros stored in the IA, JA, A arrays, see below. ! ISYM :IN Integer. ! Flag to indicate the type of matrix to generate: ! ISYM = 0 => Non-Symmetric Matrix (See FACTOR, above). ! = 1 => Symmetric Matrix. ! IA :OUT Integer IA(NELTMX). ! Stores the row indices for the non-zeros. ! JA :OUT Integer JA(NELTMX). ! Stores the column indices for the non-zeros. ! A :OUT Real A(NELTMX). ! Stores the values of the non-zeros. ! F :OUT Real F(N). ! The right hand side of the linear system. Obtained by ! multiplying the matrix times SOLN, see below. ! SOLN :OUT Real SOLN(N). ! The true solution to the linear system. Each component is ! chosen at random (0.0 NELTMX ) then IERR = 1 return end if IA(NELT) = N+1-ITMP(IROW) JA(NELT) = ICOL if ( IA(NELT) == ICOL ) then IDIAG(ICOL) = NELT else A(NELT) = -RAND(DUMMY) DSUM(ICOL) = DSUM(ICOL) + A(NELT) ! ! Copy this element into upper triangle. ! if ( ISYM == 0 ) then NELT = NELT + 1 if ( NELT > NELTMX ) then IERR = 1 return end if IA(NELT) = ICOL JA(NELT) = IA(NELT-1) A(NELT) = A(NELT-1)*FACTOR DSUM(JA(NELT)) = DSUM(JA(NELT)) + A(NELT) else DSUM(IA(NELT)) = DSUM(IA(NELT)) + A(NELT) end if end if 20 continue ! ! Add a diagonal to the column. ! if ( IDIAG(ICOL) == 0 ) then NELT = NELT + 1 if ( NELT > NELTMX ) then IERR = 1 return end if IDIAG(ICOL) = NELT A(NELT) = 0.0E0 IA(NELT) = ICOL JA(NELT) = ICOL end if ! ! Clean up the diagonals. ! !VD$ NODEPCHK !LLL. OPTION ASSERT (NOHAZARD) !DIR$ IVDEP 30 continue DO 40 I = 1, N A(IDIAG(I)) = -1.0001E0*DSUM(I) ! ! Set a random solution and determine the right-hand side. ! !VD$ NOVECTOR !VD$ NOCONCUR 40 continue DO 50 I = 1, N SOLN(I) = RAND(DUMMY) F(I) = 0.0E0 ! !VD$ NOVECTOR !VD$ NOCONCUR 50 continue DO 60 K = 1, NELT F(IA(K)) = F(IA(K)) + A(K)*SOLN(JA(K)) if ( ISYM /= 0 .and. IA(K) /= JA(K) ) then F(JA(K)) = F(JA(K)) + A(K)*SOLN(IA(K)) end if 60 continue ! -------- LAST LINE OF SRMGEN FOLLOWS ---------------------------- return end !! SSRTQC !***SUBSIDIARY !***PURPOSE Quick check for SLATEC routines SSORT, SPSORT, SPPERM !***LIBRARY SLATEC !***CATEGORY N6A !***TYPE SINGLE PRECISION (SSRTQC-S, DSRTQC-D, ISRTQC-I, HSRTQC-H) !***KEYWORDS QUICK CHECK, SPPERM, SPSORT, SSORT !***AUTHOR Boisvert, Ronald, (NIST) !***REFERENCES (NONE) !***ROUTINES CALLED SPPERM, SPSORT, SSORT !***REVISION HISTORY (YYMMDD) ! 890620 DATE WRITTEN ! 901005 Included test of SPPERM. (MAM) ! 920511 Added error message tests. (MAM) !***END PROLOGUE SSRTQC ! subroutine SSRTQC (LUN, KPRINT, IPASS) integer N, NTEST ! PARAMETER (N=9,NTEST=4) LOGICAL FAIL REAL X(N,NTEST), XS(N,NTEST), Y(N), YC(N) integer IX(N,NTEST), IY(N), KFLAG(NTEST), KPRINT, LUN, IPASS, J, & ! ! --------- ! TEST DATA ! --------- ! ! X = TEST VECTOR ! XS = TEST VECTOR IN SORTED ORDER ! IX = PERMUTATION VECTOR, I.E. X(IX(J)) = XS(J) ! I, KABS, IER, NERR, NUMXER, NN, KKFLAG DATA KFLAG(1) / 2 / DATA (X(I,1),I=1,N) /36.,54.,-1.,29., 1.,80.,98.,99.,55./ DATA (IX(I,1),I=1,N)/ 3, 5, 4, 1, 2, 9, 6, 7, 8 / ! DATA (XS(I,1),I=1,N)/-1., 1.,29.,36.,54.,55.,80.,98.,99./ DATA KFLAG(2) / -1 / DATA (X(I,2),I=1,N) / 1., 2., 3., 4., 5., 6., 7., 8., 9./ DATA (IX(I,2),I=1,N)/ 9, 8, 7, 6, 5, 4, 3, 2, 1 / ! DATA (XS(I,2),I=1,N)/ 9., 8., 7., 6., 5., 4., 3., 2., 1./ DATA KFLAG(3) / -2 / DATA (X(I,3),I=1,N) / -9.,-8.,-7.,-6.,-5.,-4.,-3.,-2.,-1./ DATA (IX(I,3),I=1,N)/ 9, 8, 7, 6, 5, 4, 3, 2, 1 / ! DATA (XS(I,3),I=1,N)/ -1.,-2.,-3.,-4.,-5.,-6.,-7.,-8.,-9./ DATA KFLAG(4) / 1 / DATA (X(I,4),I=1,N) / 36.,54.,-1.,29., 1.,80.,98.,99.,55./ DATA (IX(I,4),I=1,N)/ 3, 5, 4, 1, 2, 9, 6, 7, 8 / ! !***FIRST EXECUTABLE STATEMENT SSRTQC DATA (XS(I,4),I=1,N)/ -1., 1.,29.,36.,54.,55.,80.,98.,99./ if ( kprint >= 2 ) then write (LUN,2001) '=================' write (LUN,2002) 'OUTPUT FROM SSRTQC' write (LUN,2002) '=================' end if ! ! ------------------------------------------------------------- ! CHECK SSORT ! ------------------------------------------------------------- ! ipass = 1 ! ! ... SETUP PROBLEM ! DO 200 J=1,NTEST DO 110 I=1,N Y(I) = X(I,J) YC(I) = X(I,J) ! ! ... call ROUTINE TO BE TESTED ! 110 continue ! ! ... EVALUATE RESULTS ! call SSORT(Y,YC,N,KFLAG(J)) KABS = ABS(KFLAG(J)) FAIL = .FALSE. DO 120 I=1,N FAIL = FAIL .OR. (Y(I) /= XS(I,J)) & .OR. ((KABS == 1) .and. (YC(I) /= X(I,J))) & .OR. ((KABS == 2) .and. (YC(I) /= XS(I,J))) ! ! ... PRODUCE REQUIRED OUTPUT ! 120 continue if ( FAIL ) then ipass = 0 if ( kprint > 0) WRITE(LUN,2001) 'SSORT FAILED TEST ',J else if ( kprint >= 2) WRITE(LUN,2001) 'SSORT PASSED TEST ',J end if if ( (FAIL .and. (KPRINT >= 2)) .OR. (KPRINT >= 3) ) then write (LUN,2001) '------------------------' write (LUN,2002) 'DETAILS OF SSORT TEST ',J write (LUN,2002) '------------------------' write (LUN,2002) '1ST ARGUMENT (VECTOR TO BE SORTED)' write (LUN,2003) ' INPUT = ',(X(I,J),I=1,N) write (LUN,2003) ' COMPUTED OUTPUT = ',(Y(I),I=1,N) write (LUN,2003) ' CORRECT OUTPUT = ',(XS(I,J),I=1,N) write (LUN,2002) '2ND ARGUMENT (VECTOR CARRIED ALONG)' write (LUN,2003) ' INPUT = ',(X(I,J),I=1,N) write (LUN,2003) ' COMPUTED OUTPUT = ',(YC(I),I=1,N) if ( KABS == 1 ) then write (LUN,2003) ' CORRECT OUTPUT = ',(X(I,J),I=1,N) else write (LUN,2003) ' CORRECT OUTPUT = ',(XS(I,J),I=1,N) end if write (LUN,2002) '3RD ARGUMENT (VECTOR LENGTH)' write (LUN,2004) ' INPUT = ',N write (LUN,2002) '4TH ARGUMENT (TYPE OF SORT)' write (LUN,2004) ' INPUT = ',KFLAG(J) end if ! ! ------------------------------------------------------------- ! CHECK SPSORT ! ------------------------------------------------------------- ! 200 continue ! ! ... SETUP PROBLEM ! DO 300 J=1,NTEST DO 210 I=1,N Y(I) = X(I,J) ! ! ... call ROUTINE TO BE TESTED ! 210 continue ! ! ... EVALUATE RESULTS ! call SPSORT(Y,N,IY,KFLAG(J),IER) KABS = ABS(KFLAG(J)) FAIL = .FALSE. .OR. (IER > 0) DO 220 I=1,N FAIL = FAIL .OR. (IY(I) /= IX(I,J)) & .OR. ((KABS == 1) .and. (Y(I) /= X(I,J))) & .OR. ((KABS == 2) .and. (Y(I) /= XS(I,J))) ! ! ... PRODUCE REQUIRED OUTPUT ! 220 continue if ( FAIL ) then ipass = 0 if ( kprint > 0) WRITE(LUN,2001) 'SPSORT FAILED TEST ',J else if ( kprint >= 2) WRITE(LUN,2001) 'SPSORT PASSED TEST ',J end if if ( (FAIL .and. (KPRINT >= 2)) .OR. (KPRINT >= 3) ) then write (LUN,2001) '-------------------------' write (LUN,2002) 'DETAILS OF SPSORT TEST ',J write (LUN,2002) '-------------------------' write (LUN,2002) '1ST ARGUMENT (VECTOR TO BE SORTED)' write (LUN,2003) ' INPUT = ',(X(I,J),I=1,N) write (LUN,2003) ' COMPUTED OUTPUT = ',(Y(I),I=1,N) if ( KABS == 1 ) then write (LUN,2003) ' CORRECT OUTPUT = ',(X(I,J),I=1,N) else write (LUN,2003) ' CORRECT OUTPUT = ',(XS(I,J),I=1,N) end if write (LUN,2002) '2ND ARGUMENT (VECTOR LENGTH)' write (LUN,2004) ' INPUT = ',N write (LUN,2002) '3RD ARGUMENT (PERMUTATION VECTOR)' write (LUN,2004) ' COMPUTED OUTPUT = ',(IY(I),I=1,N) write (LUN,2004) ' CORRECT OUTPUT = ',(IX(I,J),I=1,N) write (LUN,2002) '4TH ARGUMENT (TYPE OF SORT)' write (LUN,2004) ' INPUT = ',KFLAG(J) ! end if ! ! ... TEST ERROR MESSAGES ! 300 continue if ( kprint <= 2 ) then call xsetf ( 0 ) else call xsetf ( -1 ) ! end if NN=-1 KKFLAG=1 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call SPSORT(Y,NN,IY,KKFLAG,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 NN=1 KKFLAG=0 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call SPSORT(Y,NN,IY,KKFLAG,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 if ( (KPRINT >= 2) .and. (IPASS == 1) ) then write (LUN,*) write (LUN,*)' SPSORT PASSED ERROR MESSAGE TESTS' else if ( (KPRINT >= 1) .and. (IPASS == 0) ) then write (LUN,*) write (LUN,*)' SPSORT FAILED ERROR MESSAGE TESTS' ! ! ------------------------------------------------------------- ! CHECK SPPERM ! ------------------------------------------------------------- ! end if ! ! ... SETUP PROBLEM ! DO 400 J=1,NTEST KABS = ABS(KFLAG(J)) DO 310 I=1,N Y(I) = X(I,J) if ( KABS == 1 ) then IY(I) = I else IY(I) = IX(I,J) end if ! ! ... call ROUTINE TO BE TESTED ! 310 continue ! ! ... EVALUATE RESULTS ! call SPPERM(Y,N,IY,IER) FAIL = .FALSE. .OR. (IER > 0) DO 320 I=1,N FAIL = FAIL .OR. ((KABS == 1) .and. (IY(I) /= I)) & .OR. ((KABS == 2) .and. (IY(I) /= IX(I,J))) & .OR. ((KABS == 1) .and. (Y(I) /= X(I,J))) & .OR. ((KABS == 2) .and. (Y(I) /= XS(I,J))) ! ! ... PRODUCE REQUIRED OUTPUT ! 320 continue if ( FAIL ) then ipass = 0 if ( kprint > 0) WRITE(LUN,2001)'SPPERM FAILED TEST ',J else if ( KPRINT >= 2) WRITE(LUN,2001)'SPPERM PASSED TEST ',J end if if ( (FAIL .and. (KPRINT >= 2)) .OR. (KPRINT>=3) ) then write (LUN,2001)'------------------------' write (LUN,2002)'DETAILS OF SPPERM TEST',J write (LUN,2002)'------------------------' write (LUN,2002)'1ST ARGUMENT (VECTOR TO BE PERMUTED)' write (LUN,2003)' INPUT =',(X(I,J),I=1,N) write (LUN,2003)' COMPUTED OUTPUT =',(Y(I),I=1,N) if ( KABS == 1 ) then write (LUN,2003)' CORRECT OUTPUT =',(X(I,J),I=1,N) else write (LUN,2003)' CORRECT OUTPUT =',(XS(I,J),I=1,N) end if write (LUN,2002)'2ND ARGUMENT (VECTOR LENGTH)' write (LUN,2004)' INPUT =',N write (LUN,2002)'3RD ARGUMENT (PERMUTATION VECTOR)' write (LUN,2004)' INPUT =',(IY(I),I=1,N) write (LUN,2002)'4TH ARGUMENT (ERROR FLAG)' write (LUN,2004)' OUTPUT =',IER ! end if ! ! ... TEST ERROR MESSAGES ! 400 continue if ( kprint <= 2 ) then call xsetf ( 0 ) else call xsetf ( -1 ) end if NN=-1 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call SPPERM(Y,NN,IY,IER) ! if ( NUMXER(NERR) /= IER)IPASS=0 NN=1 IY(1)=5 if ( KPRINT >= 3)WRITE(LUN,*) call xerclr call SPPERM(Y,NN,IY,IER) if ( NUMXER(NERR) /= IER)IPASS=0 if ( (KPRINT >= 2) .and. (IPASS == 1) ) then write (LUN,*) write (LUN,*)' SPPERM PASSED ERROR MESSAGE TESTS' else if ( (KPRINT >= 1) .and. (IPASS == 0) ) then write (LUN,*) write (LUN,*)' SPPERM FAILED ERROR MESSAGE TESTS' end if ! return 2001 FORMAT(/ 1X,A,I2) 2002 FORMAT(1X,A,I2) 2003 FORMAT(1X,A,9F4.0) 2004 FORMAT(1X,A,9I4) end !! STEST !***PURPOSE Compare arrays SCOMP and STRUE. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (STEST-S, DTEST-D) !***KEYWORDS QUICK CHECK !***AUTHOR Lawson, C. L., (JPL) !***DESCRIPTION ! ! This subroutine compares arrays SCOMP and STRUE of length LEN to ! see if the term by term differences, multiplied by SFAC, are ! negligible. In the case of a significant difference, appropriate ! messages are written. ! !***ROUTINES CALLED R1MACH !***COMMON BLOCKS COMBLA !***REVISION HISTORY (YYMMDD) ! 741210 DATE WRITTEN ! 890831 Modified array declarations. (WRB) ! 890831 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 900820 Modified IF test to use function DIFF and made cosmetic ! changes to routine. (WRB) ! 901005 Removed usage of DIFF in favour of R1MACH. (RWC) ! 910501 Added TYPE record. (WRB) ! 920211 Code restructured and information added to the DESCRIPTION ! section. (WRB) !***END PROLOGUE STEST subroutine STEST (LEN, SCOMP, STRUE, SSIZE, SFAC, KPRINT) REAL SCOMP(*), STRUE(*), SSIZE(*), SFAC, SD, RELEPS, R1MACH LOGICAL PASS COMMON /COMBLA/ NPRINT, ICASE, N, INCX, INCY, MODE, PASS SAVE RELEPS !***FIRST EXECUTABLE STATEMENT STEST DATA RELEPS /0.0E0/ if ( RELEPS == 0.0E0) RELEPS = R1MACH(4) DO 100 I = 1,LEN SD = ABS(SCOMP(I)-STRUE(I)) ! ! Here SCOMP(I) is not close to STRUE(I). ! if ( SFAC*SD > ABS(SSIZE(I))*RELEPS ) then ! ! Print FAIL message and header. ! if ( PASS ) then PASS = .FALSE. if ( kprint >= 3 ) then write (NPRINT,9000) write (NPRINT,9010) end if end if if ( kprint >= 3) write (NPRINT,9020) ICASE, N, INCX, INCY, & MODE, I, SCOMP(I), STRUE(I), SD, SSIZE(I) end if 100 continue return 9000 FORMAT ('+', 39X, 'FAIL') 9010 FORMAT ('0CASE N INCX INCY MODE I', 29X, 'COMP(I)', 29X, & 'TRUE(I)', 2X, 'DIFFERENCE', 5X, 'SIZE(I)' / 1X) 9020 FORMAT (1X, I4, I3, 3I5, I3, 2E36.8, 2E12.4) end !! T0 !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED F0S !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE T0 REAL FUNCTION T0 (X) !***FIRST EXECUTABLE STATEMENT T0 REAL A,B,F0S,X,X1,Y A = 0.0E+00 B = 0.1E+01 X1 = X+0.1E+01 Y = (B-A)/X1+A T0 = (B-A)*F0S(Y)/X1/X1 return end !! T1 !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED F1S !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE T1 REAL FUNCTION T1 (X) !***FIRST EXECUTABLE STATEMENT T1 REAL A,B,F1S,X,X1,Y A = 0.0E+00 B = 0.1E+01 X1 = X+0.1E+01 Y = (B-A)/X1+A T1 = (B-A)*F1S(Y)/X1/X1 return end !! T2 !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED F2S !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE T2 REAL FUNCTION T2 (X) !***FIRST EXECUTABLE STATEMENT T2 REAL A,B,F2S,X,X1,Y A = 0.1E+00 B = 0.1E+01 X1 = X+0.1E+01 Y = (B-A)/X1+A T2 = (B-A)*F2S(Y)/X1/X1 return end !! T3 !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED F3S !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE T3 REAL FUNCTION T3 (X) !***FIRST EXECUTABLE STATEMENT T3 REAL A,B,F3S,X,X1,Y A = 0.0E+00 B = 0.5E+01 X1 = X+0.1E+01 Y = (B-A)/X1+A T3 = (B-A)*F3S(Y)/X1/X1 return end !! T4 !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED F4S !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE T4 REAL FUNCTION T4 (X) !***FIRST EXECUTABLE STATEMENT T4 REAL A,B,F4S,X,X1,Y A = 0.0E+00 B = 0.1E+01 X1 = X+0.1E+01 Y = (B-A)/X1+A T4 = (B-A)*F4S(Y)/X1/X1 return end !! T5 !***PURPOSE Subsidiary to !***LIBRARY SLATEC !***AUTHOR (UNKNOWN) !***ROUTINES CALLED F5S !***REVISION HISTORY (YYMMDD) ! ?????? DATE WRITTEN ! 891214 Prologue converted to Version 4.0 format. (BAB) !***END PROLOGUE T5 REAL FUNCTION T5 (X) !***FIRST EXECUTABLE STATEMENT T5 REAL A,B,F5S,X,X1,Y A = 0.0E+00 B = 0.1E+01 X1 = X+0.1E+01 Y = (B-A)/X1+A T5 = (B-A)*F5S(Y)/X1/X1 return end !! UIVP !***PURPOSE Dummy routine for BVSUP quick check. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (UIVP-S, DUIVP-D) !***KEYWORDS QUICK CHECK !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! This routine is never called; it is here to prevent loaders from ! complaining about undefined externals while testing BVSUP. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920401 Variables declaration and TYPE sections added. (WRB) !***END PROLOGUE UIVP ! .. Scalar Arguments .. subroutine UIVP (X, Y, YP) ! .. Array Arguments .. REAL X !***FIRST EXECUTABLE STATEMENT UIVP REAL Y(*), YP(*) STOP end !! UVEC !***PURPOSE Dummy routine for BVSUP quick check. !***LIBRARY SLATEC !***TYPE SINGLE PRECISION (UVEC-S, DUVEC-D) !***KEYWORDS QUICK CHECK !***AUTHOR Watts, H. A., (SNLA) !***DESCRIPTION ! ! This routine is never called; it is here to prevent loaders from ! complaining about undefined externals while testing BVSUP. ! !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 750601 DATE WRITTEN ! 890618 REVISION DATE from Version 3.2 ! 891214 Prologue converted to Version 4.0 format. (BAB) ! 920401 Variables declaration and TYPE sections added. (WRB) !***END PROLOGUE UVEC ! .. Scalar Arguments .. subroutine UVEC (X, Y, YP) ! .. Array Arguments .. REAL X !***FIRST EXECUTABLE STATEMENT UVEC REAL Y(*), YP(*) STOP end !! VFILL !***SUBSIDIARY !***PURPOSE Fill a vector with a value. !***LIBRARY SLATEC (SLAP) !***TYPE SINGLE 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 ! REAL V(N), VAL ! ! call VFILL( N, V, VAL ) ! ! *Arguments: ! N :IN Integer. ! Length of the vector ! V :OUT Real V(N). ! Vector to be set. ! VAL :IN Real. ! Value to seed the vector with. !***REFERENCES (NONE) !***ROUTINES CALLED (NONE) !***REVISION HISTORY (YYMMDD) ! 871119 DATE WRITTEN ! 881213 Previous REVISION DATE ! 890920 Converted prologue to SLATEC 4.0 format. (FNF) ! 920511 Added complete declaration section. (WRB) !***END PROLOGUE VFILL ! .. Scalar Arguments .. subroutine VFILL (N, V, VAL) REAL VAL ! .. Array Arguments .. integer N ! .. Local Scalars .. REAL V(*) ! .. Intrinsic Functions .. integer I, IS, NR !***FIRST EXECUTABLE STATEMENT VFILL 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 VFILL FOLLOWS ----------------------------- return end subroutine XCSRT (DNU1, NUDIFF, MU1, MU2, THETA, P, Q, R, IP, IQ, & !! XCSRT !***PURPOSE TO COMPUTE CHECK VALUES FOR LEGENDRE FUNCTIONS !***LIBRARY SLATEC !***CATEGORY C3A2, C9 !***TYPE DOUBLE PRECISION (XCRST-S, DXCRST-D) !***KEYWORDS LEGENDRE FUNCTIONS !***AUTHOR SMITH, JOHN M., (NBS AND GEORGE MASON UNIVERSITY) !***DESCRIPTION ! ! SUBROUTINE XCSRT CALCULATES CASORATI (CROSS PRODUCT) ! CHECK VALUES AND STORES THEM IN ARRAYS C1 AND C2 WITH ! EXPONENTS IN ARRAYS IC1 AND IC2. CALCULATIONS ARE BASED ! ON PREVIOUSLY CALCULATED LEGENDRE FUNCTIONS OF THE ! FIRST KIND (NEGATIVE ORDER) IN ARRAY P, THE SECOND KIND ! IN ARRAY Q, THE FIRST KIND (POSITIVE ORDER) IN ARRAY R. ! RESULTS SHOULD BE 1.0 TO WITHIN ROUNDOFF ERROR. ! !***SEE ALSO FCNQX1 !***REFERENCES OLVER AND SMITH,J.COMPUT.PHYSICS,51(1983),NO.3,502-518. !***ROUTINES CALLED XADD, XADJ, XRED !***REVISION HISTORY (YYMMDD) ! 820728 DATE WRITTEN ! 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) ! 901019 Revisions to prologue. (DWL and WRB) ! 901106 Changed all specific intrinsics to generic. (WRB) !***END PROLOGUE XCSRT IR, C1, IC1, C2, IC2, IERROR) REAL C1,C2,DMU,DMU1,NU,DNU1,P,Q,R,THETA,SX,X1,X2 dimension P(*),IP(*),Q(*),IQ(*),R(*),IR(*) ! ! PLACE ALL INPUT IN ADJUSTED FORM. ! !***FIRST EXECUTABLE STATEMENT XCSRT dimension C1(*),IC1(*),C2(*),IC2(*) IERROR=0 L=NUDIFF+(MU2-MU1)+1 LM1=L-1 DO 500 I=1,L call XADJ(P(I),IP(I),IERROR) if ( IERROR /= 0) RETURN call XADJ(Q(I),IQ(I),IERROR) if ( IERROR /= 0) RETURN call XADJ(R(I),IR(I),IERROR) if ( IERROR /= 0) RETURN ! ! CHECKS FOR FIXED MU, VARIABLE NU ! 500 continue if ( MU2 > MU1) GO TO 700 DMU1=MU1 DO 650 I=1,LM1 C1(I)=0. C2(I)=0. ! ! CASORATI 2 ! ! (MU+NU+1)*P(-MU,NU+1,X)*Q(MU,NU,X) ! +(MU-NU-1)*P(-MU,NU,X)*Q(MU,NU+1,X)=COS(MU*PI) ! NU=DNU1+I-1. X1=P(I+1)*Q(I) IX1=IP(I+1)+IQ(I) call XADJ(X1,IX1,IERROR) if ( IERROR /= 0) RETURN X2=P(I)*Q(I+1) IX2=IP(I)+IQ(I+1) call XADJ(X2,IX2,IERROR) if ( IERROR /= 0) RETURN X1=(DMU1+NU+1.)*X1 X2=(DMU1-NU-1.)*X2 call XADD(X1,IX1,X2,IX2,C1(I),IC1(I),IERROR) if ( IERROR /= 0) RETURN call XADJ(C1(I),IC1(I),IERROR) ! ! MULTIPLY BY (-1)**MU SO THAT CHECK VALUE IS 1. ! if ( IERROR /= 0) RETURN ! ! CASORATI 1 ! ! P(MU,NU+1,X)*Q(MU,NU,X)-P(MU,NU,X)*Q(MU,NU+1,X)= ! GAMMA(NU+MU+1)/GAMMA(NU-MU+2) ! C1(I)=C1(I)*(-1)**MU1 if ( DMU1 >= NU+1. .and. MOD(NU,1.) == 0.) GO TO 630 X1=R(I+1)*Q(I) IX1=IR(I+1)+IQ(I) call XADJ(X1,IX1,IERROR) if ( IERROR /= 0) RETURN X2=R(I)*Q(I+1) IX2=IR(I)+IQ(I+1) call XADJ(X2,IX2,IERROR) if ( IERROR /= 0) RETURN call XADD(X1,IX1,-X2,IX2,C2(I),IC2(I),IERROR) ! ! DIVIDE BY (NU+MU),(NU+MU-1),(NU+MU-2),....(NU-MU+2), ! SO THAT CHECK VALUE IS 1. ! if ( IERROR /= 0) RETURN K=2*MU1-1 DO 620 J=1,K if ( K <= 0) GO TO 620 C2(I)=C2(I)/(NU+DMU1+1.-J) 620 call XADJ(C2(I),IC2(I),IERROR) if ( IERROR /= 0) RETURN if ( K <= 0) C2(I)=(NU+1.)*C2(I) GO TO 650 630 C2(I)=0. IC2(I)=0 650 continue ! ! CHECKS FOR FIXED NU, VARIABLE MU ! GO TO 800 700 continue SX=SIN(THETA) DO 750 I=1,LM1 C1(I)=0. ! ! CASORATI 4 ! ! (MU+NU+1)*(MU-NU)*P(-(MU+1),NU,X)*Q(MU,NU,X) ! -P(-MU,NU,X)*Q(MU+1,NU,X)=COS(MU*PI)/SQRT(1-X**2) ! C2(I)=0. MU=MU1+I-1 DMU=MU X1=P(I+1)*Q(I) IX1=IP(I+1)+IQ(I) call XADJ(X1,IX1,IERROR) if ( IERROR /= 0) RETURN X2=P(I)*Q(I+1) IX2=IP(I)+IQ(I+1) call XADJ(X2,IX2,IERROR) if ( IERROR /= 0) RETURN ! ! MULTIPLY BY SQRT(1-X**2)*(-1)**MU SO THAT CHECK VALUE IS 1. ! X1=(DMU+DNU1+1.)*(DMU-DNU1)*X1 call XADD(X1,IX1,-X2,IX2,C1(I),IC1(I),IERROR) if ( IERROR /= 0) RETURN C1(I)=SX*C1(I)*(-1)**MU call XADJ(C1(I),IC1(I),IERROR) ! ! CASORATI 3 ! ! P(MU+1,NU,X)*Q(MU,NU,X)-P(MU,NU,X)*Q(MU+1,NU,X)= ! GAMMA(NU+MU+1)/(GAMMA(NU-MU+1)*SQRT(1-X**2)) ! if ( IERROR /= 0) RETURN if ( DMU >= DNU1+1. .and. MOD(DNU1,1.) == 0.) GO TO 750 X1=R(I+1)*Q(I) IX1=IR(I+1)+IQ(I) call XADJ(X1,IX1,IERROR) if ( IERROR /= 0) RETURN X2=R(I)*Q(I+1) IX2=IR(I)+IQ(I+1) call XADJ(X2,IX2,IERROR) if ( IERROR /= 0) RETURN call XADD(X1,IX1,-X2,IX2,C2(I),IC2(I),IERROR) ! ! MULTIPLY BY SQRT(1-X**2) AND THEN DIVIDE BY ! (NU+MU),(NU+MU-1),(NU+MU-2),...,(NU-MU+1) SO THAT ! CHECK VALUE IS 1. ! if ( IERROR /= 0) RETURN C2(I)=C2(I)*SX K=2*MU if ( K <= 0) GO TO 750 DO 740 J=1,K C2(I)=C2(I)/(DNU1+DMU+1.-J) 740 call XADJ(C2(I),IC2(I),IERROR) if ( IERROR /= 0) RETURN ! ! PLACE RESULTS IN REDUCED FORM. ! 750 continue 800 DO 810 I=1,LM1 call XRED(C1(I),IC1(I),IERROR) if ( IERROR /= 0) RETURN call XRED(C2(I),IC2(I),IERROR) if ( IERROR /= 0) RETURN 810 continue return end !! ZQCAI !***SUBSIDIARY !***PURPOSE Quick check for SLATEC subroutines ! ZAIRY, ZBIRY !***LIBRARY SLATEC !***CATEGORY C10D !***TYPE COMPLEX (CQCAI-C, ZQCAI-Z) !***KEYWORDS QUICK CHECK, ZAIRY, ZBIRY !***AUTHOR Amos, Don, (SNL) ! Goudy, Sue, (SNL) ! Walton, Lee, (SNL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call ZQCAI (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: ! ! *** A DOUBLE PRECISION ROUTINE *** ! ! ZQCAI is a quick check routine for the complex Airy functions ! generated by subroutines ZAIRY and ZBIRY. ! ! ZQCAI generates Airy functions and their derivatives from ZAIRY ! and ZBIRY 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 ZAIRY, ZBIRY, ZABS, ZSQRT, ZEXP, i1mach, d1mach !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890831 Revised to meet new SLATEC standards ! 930122 Added ZEXP and ZSQRT to EXTERNAL statement. (RWC) !***END PROLOGUE ZQCAI ! !*Internal Notes: ! Machine constants are defined by functions i1mach and d1mach. ! ! 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 ZQCAI (LUN, KPRINT, IPASS) integer MQC ! ! Declare arguments. ! PARAMETER (MQC=1) ! ! Declare external functions. ! integer LUN, KPRINT, IPASS integer i1mach double precision d1mach, ZABS ! ! Declare local variables. ! EXTERNAL i1mach, d1mach, ZABS, ZEXP, ZSQRT double precision CON1R,CON1I, CON2R,CON2I, CON3R,CON3I, CVR,CVI, & CWR,CWI, CYR,CYI, WR,WI, YR,YI, ZR,ZI, ZRR,ZRI double precision AA, AB, ACW, ACY, ALIM, ARG, ATOL, AV, AZRR, A1, & A2, CT, C23, DIG, ELIM, EPS, ER, ERTOL, FILM, FNUL, FPI, HPI, & PI, PI3, PTR, R, RL, RM, RPI, RTPI, R1M4, R1M5, SLAK, SPI, ST, & STI, STR, 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 dimension KDO(20), KEPS(20), T(20), WR(20), WI(20), YR(20), & ! !***FIRST EXECUTABLE STATEMENT ZQCAI YI(20) if ( KPRINT >= 2 ) then write (LUN,99999) 99999 FORMAT (' QUICK CHECK ROUTINE FOR THE AIRY FUNCTIONS FROM ', & 'ZAIRY AND ZBIRY'/) ! ------------------------------------------------------------------ ! Set parameters related to machine constants. ! TOL is the approximate unit roundoff limited to 1.0D-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 = d1mach(4) TOL = max ( R1M4,1.0D-18) ATOL = 100.0D0*TOL AA = -LOG10(R1M4) K1 = i1mach(12) K2 = i1mach(13) R1M5 = d1mach(5) K = min ( ABS(K1),ABS(K2)) ELIM = 2.303D0*(K*R1M5-3.0D0) AB = AA*2.303D0 ALIM = ELIM + max ( -AB,-41.45D0) DIG = min ( AA,18.0D0) SLAK = 3.0D0+4.0D0*(-LOG10(TOL)-7.0D0)/11.0D0 SLAK = max ( SLAK,3.0D0) ERTOL = TOL*10.0D0**SLAK RL = 1.2D0*DIG + 3.0D0 RM = 0.5D0*(ALIM + ELIM) RM = min ( RM,200.0D0) RM = max ( RM,RL+10.0D0) FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) 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 (6D12.4/) ! ------------------------------------------------------------------ ! Generate angles for construction of complex Z to be used in tests. ! ------------------------------------------------------------------ end if FPI = ATAN(1.0D0) HPI = FPI + FPI PI = HPI + HPI TPI = PI + PI RPI = 1.0D0/PI TPI3 = TPI/3.0D0 SPI = PI/6.0D0 PI3 = SPI+SPI RTPI = 1.0D0/TPI A1 = RTPI*COS(SPI) A2 = RTPI*SIN(SPI) CON1R = COS(TPI3) CON1I = SIN(TPI3) CON2R = A1 CON2I = -A2 CON3R = RPI CON3I = 0.0D0 ! ------------------------------------------------------------------ ! 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.0D0/3.0D0 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.01D0 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.0D0*(IR-1)/3.0D0 GO TO 70 50 continue R = (2.0D0*(4-IR)+RL*(IR-1))/3.0D0 GO TO 70 60 continue R = (RL*(4-IR)+RM*(IR-1))/3.0D0 ! ------- 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.0D0 if ( ABS(ST) < ATOL) ST = 0.0D0 ZR = R*CT ZI = R*ST call ZSQRT(ZR, ZI, STR, STI) PTR = (ZR*STR-ZI*STI)*C23 ZRI = (ZR*STI+ZI*STR)*C23 ZRR = PTR ! --------- Check for possible underflow or overflow AZRR = ABS(ZRR) if ( AZRR /= 0.0D0 ) then ARG = -AZRR - 0.5D0*LOG(AZRR) + 0.226D0 ! ----------- Skip test for this case? ARG = ARG + ARG if ( ARG < (-ELIM)) GO TO 140 end if call ZAIRY(ZR, ZI, 0, KODE, YR(1), YI(1), NZ1, IERR) call ZAIRY(ZR, ZI, 1, KODE, YR(2), YI(2), NZ2, IERR) ! ----------- Compare 1/PI with Wronskian of ZAIRY(Z) and ZBIRY(Z). if ( ICASE == 1 ) then call ZBIRY(ZR, ZI, 0, KODE, WR(1), WI(1), IERR) call ZBIRY(ZR, ZI, 1, KODE, WR(2), WI(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 CVR = AZRR - ZRR CVI = -ZRI call ZEXP(CVR, CVI, CVR, CVI) STR = WR(1)*CVR - WI(1)*CVI WI(1) = WR(1)*CVI + WI(1)*CVR WR(1) = STR STR = WR(2)*CVR - WI(2)*CVI WI(2) = WR(2)*CVI + WI(2)*CVR WR(2) = STR end if CVR = CON3R CVI = CON3I ! ----------- Compare exp(-i*PI/6)/2PI with Wronskian of ZAIRY(Z) ! and ZAIRY(Z*exp(2i*PI/3)). else CVR = ZR*CON1R - ZI*CON1I CVI = ZR*CON1I + ZI*CON1R call ZAIRY(CVR, CVI, 0, KODE, WR(1), WI(1), NZ3, IERR) call ZAIRY(CVR, CVI, 1, KODE, WR(2), WI(2), NZ4, IERR) if ( KODE == 2 ) then ! --------------- Adjust scaling factor. if ( T(IT) >= PI3 ) then CVR = ZRR + ZRR CVI = ZRI + ZRI call ZEXP(-CVR, -CVI, CVR, CVI) STR = WR(1)*CVR - WI(1)*CVI WI(1) = WR(1)*CVI + WI(1)*CVR WR(1) = STR STR = WR(2)*CVR - WI(2)*CVI WI(2) = WR(2)*CVI + WI(2)*CVR WR(2) = STR end if end if STR = WR(2)*CON1R - WI(2)*CON1I WI(2) = WR(2)*CON1I + WI(2)*CON1R WR(2) = STR CVR = CON2R CVI = CON2I ! ------------------------------------------------------------------ ! Error relative to maximum term ! ------------------------------------------------------------------ end if AV = ZABS(CVR,CVI) CWR = YR(1)*WR(2) - YI(1)*WI(2) CWI = YR(1)*WI(2) + YI(1)*WR(2) CYR = YR(2)*WR(1) - YI(2)*WI(1) CYI = YR(2)*WI(1) + YI(2)*WR(1) CYR = CWR - CYR - CVR CYI = CWI - CYI - CVI ACY = ZABS(YR(1),YI(1))*ZABS(WR(2),WI(2)) ACW = ZABS(WR(1),WI(1))*ZABS(YR(2),YI(2)) AV = max ( ACW,ACY,AV) ER = ZABS(CYR,CYI)/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 = ', D12.4/) write (LUN,99994) 99994 FORMAT (' INPUT TO ZAIRY AND ERROR') end if if ( KPRINT >= 3 ) then write (LUN,99993) 99993 FORMAT (' COMPARISON VALUE AND WRONSKIAN') write (LUN,99992) 99992 FORMAT (' RESULTS FROM ZAIRY AND/OR ZBIRY') write (LUN,99991) 99991 FORMAT (' TEST CASE INDICES'/) end if end if LFLG = 1 if ( KPRINT >= 2 ) then write (LUN,99990) ZR, ZI, ER 99990 FORMAT (12X,'INPUT: Z=',2D12.4,5X,'ERROR: ER=', & D12.4) end if if ( KPRINT >= 3 ) then write (LUN,99989) CVR, CVI, CYR, CYI 99989 FORMAT (' COMPARISON VALUE: CV=',2D12.4/ & 8X,'WRONSKIAN: CY=',2D12.4) write (LUN,99988) NZ1, YR(1), YI(1), & NZ2, YR(2), YI(2) 99988 FORMAT (10X,'RESULTS: NZ1=',I3,4X,'Y(1)=',2D12.4/ & 20X,'NZ2=',I3,4X,'Y(2)=',2D12.4) if ( ICASE == 1 ) then write (LUN,99987) WR(1), WI(1), WR(2), WI(2) 99987 FORMAT (31X,'W(1)=',2D12.4/31X,'W(2)=',2D12.4) else write (LUN,99986) NZ3, WR(1), WI(1), & NZ4, WR(2), WI(2) 99986 FORMAT (20X,'NZ3=',I3,4X,'W(1)=',2D12.4/ & 20X,'NZ4=',I3,4X,'W(2)=',2D12.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 ZAIRY 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 (/' ****** ZAIRY PASSED ALL TESTS ******'/) end if if ( ipass == 0 .and. KPRINT >= 1 ) then write (LUN,99981) 99981 FORMAT (/' ****** ZAIRY FAILED SOME TESTS ******'/) end if return end !! ZQCBH !***SUBSIDIARY !***PURPOSE Quick check for SLATEC subroutine ! ZBESH !***LIBRARY SLATEC !***CATEGORY C10A4 !***TYPE COMPLEX (CQCBH-C, ZQCBH-Z) !***KEYWORDS QUICK CHECK, ZBESH !***AUTHOR Amos, Don, (SNL) ! Goudy, Sue, (SNL) ! Walton, Lee, (SNL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call ZQCBH (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: ! ! *** A DOUBLE PRECISION ROUTINE *** ! ! ZQCBH is a quick check routine for the complex H Bessel functions ! generated by subroutine ZBESH. ! ! ZQCBH 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 ZBESH, ZUOIK, ZABS, ZDIV, i1mach, d1mach !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890831 Revised to meet new SLATEC standards !***END PROLOGUE ZQCBH ! !*Internal Notes: ! Machine constants are defined by functions i1mach and d1mach. ! ! 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 ZQCBH (LUN, KPRINT, IPASS) integer MQC ! ! Declare arguments. ! PARAMETER (MQC=1) ! ! Declare external functions. ! integer LUN, KPRINT, IPASS integer i1mach double precision d1mach, ZABS ! ! Declare local variables. ! EXTERNAL i1mach, d1mach, ZABS double precision CVR,CVI, CWR,CWI, CYR,CYI, WR,WI, YR,YI, ZR,ZI, & ZNR,ZNI double precision 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), WR(20), WI(20), & ! !***FIRST EXECUTABLE STATEMENT ZQCBH XNU(20), YR(20), YI(20) if ( KPRINT >= 2 ) then write (LUN,99999) 99999 FORMAT (' QUICK CHECK ROUTINE FOR THE H BESSEL FUNCTIONS FROM ', & 'ZBESH'/) ! ------------------------------------------------------------------ ! Set parameters related to machine constants. ! TOL is the approximate unit roundoff limited to 1.0D-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 = d1mach(4) TOL = max ( R1M4,1.0D-18) ATOL = 100.0D0*TOL AA = -LOG10(R1M4) K1 = i1mach(12) K2 = i1mach(13) R1M5 = d1mach(5) K = min ( ABS(K1),ABS(K2)) ELIM = 2.303D0*(K*R1M5-3.0D0) AB = AA*2.303D0 ALIM = ELIM + max ( -AB,-41.45D0) DIG = min ( AA,18.0D0) FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) RL = 1.2D0*DIG + 3.0D0 SLAK = 3.0D0+4.0D0*(-LOG10(TOL)-7.0D0)/11.0D0 SLAK = max ( SLAK,3.0D0) ERTOL = TOL*10.0D0**SLAK RM = 0.5D0*(ALIM + ELIM) RM = min ( RM,200.0D0) RM = max ( RM,RL+10.0D0) 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 (6D12.4/) ! ------------------------------------------------------------------ ! Set other constants needed in the tests. ! ------------------------------------------------------------------ end if FPI = ATAN(1.0D0) HPI = FPI + FPI PI = HPI + HPI RFPI = 1.0D0/FPI ZNR = 0.0D0 ! ------------------------------------------------------------------ ! 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. ! ------------------------------------------------------------------ ZNI = -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.0D0 XNU(2) = 1.0D0 XNU(3) = 2.0D0 XNU(4) = 0.5D0*FNUL XNU(5) = FNUL + 1.1D0 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.0D0 XNU(2) = 0.6D0 XNU(3) = 1.3D0 XNU(4) = 2.0D0 XNU(5) = 0.5D0*FNUL XNU(6) = FNUL + 1.1D0 end if I = 2 EPS = 0.01D0 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.0D0*(IR-1))/2.0D0 GO TO 80 60 continue R = (2.0D0*(3-IR)+R2*(IR-1))/2.0D0 GO TO 80 70 continue if ( R2 >= RM) GO TO 140 R = (R2*(3-IR)+RM*(IR-1))/2.0D0 ! --------- end switch 80 continue DO 120 IT = 1,ITL CT = COS(T(IT)) ST = SIN(T(IT)) if ( ABS(CT) < ATOL) CT = 0.0D0 if ( ABS(ST) < ATOL) ST = 0.0D0 ZR = R*CT ZI = R*ST ! ------------- Check for possible overflow condition if ( FNU >= 2.0D0 ) then CVR = -ZI CVI = ZR call ZUOIK(CVR, CVI, FNU, KODE, 2, N1, WR, WI, NZ2, & ! ------------- Overflow detected? - skip test for this case TOL, ELIM, ALIM) if ( NZ2 == (-1)) GO TO 120 CVR = -CVR CVI = -CVI call ZUOIK(CVR, CVI, FNU, KODE, 2, N1, WR, WI, & ! ------------- Overflow detected? - skip test for this case NZ2, TOL, ELIM, ALIM) if ( NZ2 == (-1)) GO TO 120 ! ----------- No overflow - calculate H1(Z,FNU) and H2(Z,FNU) end if call ZBESH(ZR, ZI, FNU, KODE, 1, N1, YR, YI, NZ1, & ! ----------- Underflow? - skip test for this case IERR) if ( NZ1 /= 0) GO TO 120 call ZBESH(ZR, ZI, FNU, KODE, 2, N1, WR, WI, NZ2, & ! ----------- Underflow? - skip test for this case IERR) ! ------------------------------------------------------------------ ! Compare ZN/Z with the Wronskian of H1(Z,FNU) and H2(Z,FNU). ! ZN = -4i/PI ! ------------------------------------------------------------------ if ( NZ2 /= 0) GO TO 120 call ZDIV(ZNR, ZNI, ZR, ZI, CVR, CVI) MFLG = 0 ! ------------------------------------------------------------------ ! Error relative to maximum term ! ------------------------------------------------------------------ DO 100 I = 1,N AW = ZABS(WR(I+1),WI(I+1)) AY = ZABS(YR(I),YI(I)) AZ = LOG(AW) + LOG(AY) AZ = ABS(AZ) ! --------------- No scaling problem - do error analysis if ( AZ <= ALIM ) then AV = ZABS(CVR,CVI) CWR = WR(I)*YR(I+1) - WI(I)*YI(I+1) CWI = WR(I)*YI(I+1) + WI(I)*YR(I+1) CYR = WR(I+1)*YR(I) - WI(I+1)*YI(I) CYI = WR(I+1)*YI(I) + WI(I+1)*YR(I) CYR = CWR - CYR - CVR CYI = CWI - CYI - CVI ACY = AW*AY ACW = ZABS(WR(I),WI(I))*ZABS(YR(I+1),YI(I+1)) AV = max ( ACW,ACY,AV) ER = ZABS(CYR,CYI)/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 = ',D12.4/) write (LUN,99994) 99994 FORMAT (' INPUT TO ZBESH 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 ZBESH 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) ZR, ZI, FNU, KODE, N 99990 FORMAT (' INPUT: Z=',2D12.4,4X,'FNU=',D12.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)=',4D12.4) KK = max ( NZ1,NZ2) + 1 KK = min ( N,KK) write (LUN,99988) NZ1, YR(KK), YI(KK), & NZ2, WR(KK), WI(KK) 99988 FORMAT (' RESULTS: NZ1=',I3,4X,'Y(KK)=',2D12.4/ & 11X,'NZ2=',I3,4X,'W(KK)=',2D12.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 ZBESH 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 (/' ****** ZBESH PASSED ALL TESTS ******'/) end if if ( ipass == 0 .and. KPRINT >= 1 ) then write (LUN,99983) 99983 FORMAT (/' ****** ZBESH FAILED SOME TESTS ******'/) end if return end !! ZQCBI !***SUBSIDIARY !***PURPOSE Quick check for SLATEC subroutine ! ZBESI !***LIBRARY SLATEC !***CATEGORY C10B4 !***TYPE COMPLEX (CQCBI-C, ZQCBI-Z) !***KEYWORDS QUICK CHECK, ZBESI !***AUTHOR Amos, Don, (SNL) ! Goudy, Sue, (SNL) ! Walton, Lee, (SNL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call ZQCBI (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: ! ! *** A DOUBLE PRECISION ROUTINE *** ! ! ZQCBI is a quick check routine for the complex I Bessel function ! generated by subroutine ZBESI. ! ! ZQCBI 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 ZBESI, ZBESK, ZWRSK, ZABS, ZDIV, i1mach, d1mach !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890831 Revised to meet new SLATEC standards !***END PROLOGUE ZQCBI ! !*Internal Notes: ! Machine constants are defined by functions i1mach and d1mach. ! ! 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 ZQCBI (LUN, KPRINT, IPASS) integer MQC ! ! Declare arguments. ! PARAMETER (MQC=1) ! ! Declare external functions. ! integer LUN, KPRINT, IPASS integer i1mach double precision d1mach, ZABS ! ! Declare local variables. ! EXTERNAL i1mach, d1mach, ZABS double precision CKR,CKI, CONER,CONEI, CSGNR,CSGNI, CWR,CWI, & CYR,CYI, WR,WI, YR,YI, ZR,ZI, ZNR,ZNI, ZTR,ZTI double precision 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, STI, STR, T, TOL, & TS, ZSCR, ZZR 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 dimension AER(20), CKR(2), CKI(2), KDO(20), KEPS(20), T(20), & ! !***FIRST EXECUTABLE STATEMENT ZQCBI WR(20), WI(20), YR(20), YI(20) if ( KPRINT >= 2 ) then write (LUN,99999) 99999 FORMAT (' QUICK CHECK ROUTINE FOR THE I BESSEL FUNCTION FROM ', & 'ZBESI'/) ! ------------------------------------------------------------------ ! Set parameters related to machine constants. ! TOL is the approximate unit roundoff limited to 1.0D-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 = d1mach(4) TOL = max ( R1M4,1.0D-18) ATOL = 100.0D0*TOL AA = -LOG10(R1M4) K1 = i1mach(12) K2 = i1mach(13) R1M5 = d1mach(5) K = min ( ABS(K1),ABS(K2)) ELIM = 2.303D0*(K*R1M5-3.0D0) AB = AA*2.303D0 ALIM = ELIM + max ( -AB,-41.45D0) DIG = min ( AA,18.0D0) FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) RL = 1.2D0*DIG + 3.0D0 SLAK = 3.0D0+4.0D0*(-LOG10(TOL)-7.0D0)/11.0D0 SLAK = max ( SLAK,3.0D0) ERTOL = TOL*10.0D0**SLAK RM = 0.5D0*(ALIM + ELIM) RM = min ( RM,200.0D0) RM = max ( RM,RL+10.0D0) R2 = min ( RM,FNUL) R1 = 2.0D0*SQRT(FNUL+1.0D0) 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,6D12.4/) ! ------------------------------------------------------------------ ! Set other constants needed in the tests. ! ------------------------------------------------------------------ end if ZZR = 1.0D0/TOL CONER = 1.0D0 CONEI = 0.0D0 HPI = 2.0D0*ATAN(1.0D0) ! ------------------------------------------------------------------ ! 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.01D0 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.0D0*(3-IR)+RL*(IR-1))/2.0D0 GNU = R*R/4.0D0 - 0.2D0 - (N-1) FNU = max ( 0.0D0,GNU) GO TO 110 60 continue R = (RL*(3-IR)+R2*(IR-1))/2.0D0 GNU = SQRT(R+R) - 0.2D0 - (N-1) FNU = max ( 0.0D0,GNU) GO TO 110 70 continue if ( R2 >= RM) GO TO 220 R = (R2*(3-IR)+RM*(IR-1))/2.0D0 GNU = SQRT(R+R) - 0.2D0 - (N-1) FNU = max ( 0.0D0,GNU) GO TO 110 80 continue if ( R1 >= RL) GO TO 220 R = (R1*(3-IR)+RL*(IR-1))/2.0D0 FNU = FNUL - 0.2D0 - (N-1) GO TO 110 90 continue R = (RL*(3-IR)+R2*(IR-1))/2.0D0 FNU = FNUL - 0.2D0 - (N-1) GO TO 110 100 continue if ( R2 >= RM) GO TO 220 R = (R2*(3-IR)+RM*(IR-1))/2.0D0 FNU = FNUL - 0.2D0 - (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.0D0 if ( ABS(ST) < ATOL) ST = 0.0D0 ZR = R*CT ZI = R*ST call ZBESI(ZR, ZI, FNU, KODE, N1, YR, YI, NZ1, IERR) ! ------------------------------------------------------------------ ! Compare values from ZBESI with values from ZWRSK, an alternative ! method for calculating the complex Bessel I function. ! ------------------------------------------------------------------ if ( NZ1 /= 0) GO TO 180 ZNR = ZR ZNI = ZI if ( ZR >= 0.0D0 ) then call ZWRSK(ZNR, ZNI, FNU, KODE, N, WR, WI, NZ2, CKR, & CKI, TOL, ELIM, ALIM) if ( NZ2 /= 0) GO TO 180 else ZNR = -ZR ZNI = -ZI INU = INT(FNU) ARG = (FNU-INU)*PI if ( ZI < 0.0D0) ARG = -ARG CARG = COS(ARG) SARG = SIN(ARG) CSGNR = CARG CSGNI = SARG if ( MOD(INU,2) == 1 ) then CSGNR = -CSGNR CSGNI = -CSGNI end if call ZWRSK(ZNR, ZNI, FNU, KODE, N, WR, WI, NZ2, CKR, & CKI, TOL, ELIM, ALIM) if ( NZ2 /= 0) GO TO 180 DO 130 I = 1,N STR = WR(I)*CSGNR - WI(I)*CSGNI WI(I) = WR(I)*CSGNI + WI(I)*CSGNR WR(I) = STR CSGNR = -CSGNR CSGNI = -CSGNI 130 continue end if MFLG = 0 DO 160 I = 1,N AB = FNU + I - 1 AA = max ( 2.0D0,AB) ZTR = WR(I) ZTI = WI(I) if ( ABS(ZTR) > 1.0D0 .OR. ABS(ZTI) > 1.0D0 ) then ZSCR = TOL else ! ------------- ZZR = 1.0D0/TOL ZSCR = ZZR end if CWR = WR(I)*ZSCR CWI = WI(I)*ZSCR CYR = YR(I)*ZSCR CYI = YI(I)*ZSCR STR = CYR - CWR STI = CYI - CWI ER = ZABS(STR,STI) AW = ZABS(CWR,CWI) if ( AW /= 0.0D0 ) then if ( ZR == 0.0D0 ) then if ( ABS(ZI) < AA ) then ER = ER/AW else STR = YR(I)-WR(I) STI = YI(I)-WI(I) ER = ZABS(STR,STI) end if else ER = ER/AW end if else ER = ZABS(YR(I),YI(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 = ', D12.4/) write (LUN,99994) 99994 FORMAT (' INPUT TO ZBESI Z, FNU, KODE, N') end if if ( KPRINT >= 3 ) then write (LUN,99993) 99993 FORMAT (' ERROR TEST ON RESULTS FROM ZBESI AND ', & 'ZWRSK AER(K)') write (LUN,99992) 99992 FORMAT (' RESULTS FROM ZBESI NZ1, Y(KK)'/, & ' RESULTS FROM ZWRSK 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) ZR, ZI, FNU, KODE, N 99990 FORMAT (' INPUT: Z=',2D12.4,4X,'FNU=',D12.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)=',4D12.4) KK = max ( NZ1,NZ2) + 1 KK = min ( N,KK) write (LUN,99988) NZ1, YR(KK), YI(KK), & NZ2, WR(KK), WI(KK) 99988 FORMAT (' RESULTS: NZ1=',I3,4X,'Y(KK)=',2D12.4, & /11X,'NZ2=',I3,4X,'W(KK)=',2D12.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 ZBESI 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 ZR = 1.4D0 ZI = 1.4D0 KODE = 1 N = 20 DO 280 I = 1,2 ! ------------------------------------------------------------------ ! Adjust FNU by repeating until 0.lt.NZI.lt.10 ! ------------------------------------------------------------------ FNU = 10.2D0 230 continue call ZBESI(ZR, ZI, FNU, KODE, N, YR, YI, NZI, IERR) if ( NZI /= 0 ) then if ( NZI >= 10 ) then FNU = FNU - 1.0D0 GO TO 230 end if else FNU = FNU + 5.0D0 GO TO 230 ! - End repeat end if call ZBESK(ZR, ZI, FNU, KODE, 2, WR, WI, NZK, IERR) call ZDIV(CONER, CONEI, ZR, ZI, ZTR, ZTI) CYR = WR(1)*YR(2) - WI(1)*YI(2) CYI = WR(1)*YI(2) + WI(1)*YR(2) CWR = WR(2)*YR(1) - WI(2)*YI(1) CWI = WR(2)*YI(1) + WI(2)*YR(1) CWR = CWR + CYR - ZTR CWI = CWI + CYI - ZTI ! ------------------------------------------------------------------ ! Write failure reports for KPRINT.ge.2 and KPRINT.ge.3 ! ------------------------------------------------------------------ ER = ZABS(CWR,CWI)/ZABS(ZTR,ZTI) if ( ER >= ERTOL ) then if ( IPRNT == 0 ) then if ( KPRINT >= 2 ) then write (LUN,99983) 99983 FORMAT (' INPUT TO ZBESI Z, FNU, KODE, N') end if if ( KPRINT >= 3 ) then write (LUN,99982) 99982 FORMAT (' COMPARE 1/Z WITH WRONSKIAN(ZBESI(Z,FNU),', & 'ZBESK(Z,FNU))'/) end if end if IPRNT = 1 if ( KPRINT >= 2 ) then write (LUN,99981) ZR, ZI, FNU, KODE, N 99981 FORMAT (' INPUT: Z=',2D12.4,3X,'FNU=',D12.4,3X,'KODE=',I3, & 3X,'N=',I3) end if if ( KPRINT >= 3 ) then write (LUN,99980) ZTR, ZTI, CWR+CYR, CWI+CYI 99980 FORMAT (' RESULTS:',15X,'1/Z=',2D12.4/ & 10X,'WRON(ZBESI,ZBESK)=',2D12.4) write (LUN,99979) ER 99979 FORMAT (' RELATIVE ERROR:',9X,'ER=',D12.4/) end if end if RLT = RL + RL ZR = RLT ZI = 0.0D0 ! ------------------------------------------------------------------ ! 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 ZR = ELIM ZI = 0.0D0 ! ------------------------------------------------------------------ ! Adjust FNU by repeating until NZK.lt.10 ! N = 20 set before DO 280 loop ! ------------------------------------------------------------------ FNU = 0.0D0 290 continue call ZBESK(ZR, ZI, FNU, KODE, N, YR, YI, NZK, IERR) if ( NZK >= 10 ) then if ( NZK == N ) then FNU = FNU + 3.0D0 else FNU = FNU + 2.0D0 end if GO TO 290 !---- End repeat end if GNU = FNU + (N-2) call ZBESI(ZR, ZI, GNU, KODE, 2, WR, WI, NZI, IERR) call ZDIV(CONER, CONEI, ZR, ZI, ZTR, ZTI) CYR = YR(N-1)*WR(2) - YI(N-1)*WI(2) CYI = YR(N-1)*WI(2) + YI(N-1)*WR(2) CWR = YR(N)*WR(1) - YI(N)*WI(1) CWI = YR(N)*WI(1) + YI(N)*WR(1) CWR = CWR + CYR - ZTR CWI = CWI + CYI - ZTI ER = ZABS(CWR,CWI)/ZABS(ZTR,ZTI) 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) ZR, ZI, FNU, KODE, N end if if ( KPRINT >= 3 ) then write (LUN,99980) ZTR, ZTI, CWR+CYR, CWI+CYI 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 ZBESI 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 (/' ****** ZBESI PASSED ALL TESTS ******'/) end if if ( ipass == 0 .and. KPRINT >= 1 ) then write (LUN,99976) 99976 FORMAT (/' ****** ZBESI FAILED SOME TESTS ******'/) end if return end subroutine ZQCBJ (LUN, KPRINT, IPASS) !! ZQCBJ !***SUBSIDIARY !***PURPOSE Quick check for SLATEC subroutine ! ZBESJ !***LIBRARY SLATEC !***CATEGORY C10A4 !***TYPE COMPLEX (CQCBJ-C, ZQCBJ-Z) !***KEYWORDS QUICK CHECK, ZBESJ !***AUTHOR Amos, Don, (SNL) ! Goudy, Sue, (SNL) ! Walton, Lee, (SNL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call ZQCBJ (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: ! ! *** A DOUBLE PRECISION ROUTINE *** ! ! ZQCBJ is a quick check routine for the complex J Bessel function ! generated by subroutine ZBESJ. ! ! ZQCBJ generates sequences of J Bessel functions from ZBESJ ! 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 ZBESJ 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 ZBESH, ZBESJ, ZABS, ZEXP, i1mach, d1mach !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890831 Revised to meet new SLATEC standards ! 930122 Added ZEXP to EXTERNAL statement. (RWC) !***END PROLOGUE ZQCBJ ! !*Internal Notes: ! Machine constants are defined by functions i1mach and d1mach. ! ! 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. ! integer MQC ! ! Declare arguments. ! PARAMETER (MQC=1) ! ! Declare external functions. ! integer LUN, KPRINT, IPASS integer i1mach double precision d1mach, ZABS ! ! Declare local variables. ! EXTERNAL i1mach, d1mach, ZABS, ZEXP double precision COE1R,COE1I, COE2R,COE2I, CWR,CWI, HALFR,HALFI, & VR,VI, WR,WI, YR,YI, ZR,ZI double precision AA, AB, AER, AI, ALIM, AR, ATOL, AV, CC, CT, DD, & DIG, ELIM, EPS, ER, ERTOL, FILM, FNU, FNUL, GNU, HPI, PI, R, & RL, RM, R1M4, R1M5, R2, SLAK, ST, STR, T, TOL, TS, XNU 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), VR(20), VI(20), & ! !***FIRST EXECUTABLE STATEMENT ZQCBJ WR(20), WI(20), XNU(20), YR(20), YI(20) if ( KPRINT >= 2 ) then write (LUN,99999) 99999 FORMAT (' QUICK CHECK ROUTINE FOR THE J BESSEL FUNCTION FROM ', & 'ZBESJ'/) ! ------------------------------------------------------------------ ! Set parameters related to machine constants. ! TOL is the approximate unit roundoff limited to 1.0D-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 = d1mach(4) TOL = max ( R1M4,1.0D-18) ATOL = 100.0D0*TOL AA = -LOG10(R1M4) K1 = i1mach(12) K2 = i1mach(13) R1M5 = d1mach(5) K = min ( ABS(K1),ABS(K2)) ELIM = 2.303D0*(K*R1M5-3.0D0) AB = AA*2.303D0 ALIM = ELIM + max ( -AB,-41.45D0) DIG = min ( AA,18.0D0) FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) RL = 1.2D0*DIG + 3.0D0 SLAK = 3.0D0+4.0D0*(-LOG10(TOL)-7.0D0)/11.0D0 SLAK = max ( SLAK,3.0D0) ERTOL = TOL*10.0D0**SLAK RM = 0.5D0*(ALIM + ELIM) RM = min ( RM,200.0D0) RM = max ( RM,RL+10.0D0) 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,6D12.4/) ! ! Set other constants needed in the tests. ! end if HALFR = 0.5D0 HALFI = 0.0D0 HPI = 2.0D0*ATAN(1.0D0) ! ! 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 KEPS(1:il) = 0 KDO(1:il) = 0 NUL = 5 XNU(1) = 0.0D0 XNU(2) = 1.0D0 XNU(3) = 2.0D0 XNU(4) = 0.5D0*FNUL XNU(5) = FNUL + 1.1D0 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.0D0 XNU(2) = 0.6D0 XNU(3) = 1.3D0 XNU(4) = 2.0D0 XNU(5) = 0.5D0*FNUL XNU(6) = FNUL + 1.1D0 end if I = 2 EPS = 0.01D0 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.0D0*(IR-1))/3.0D0 GO TO 80 60 continue R = (2.0D0*(4-IR)+R2*(IR-1))/3.0D0 GO TO 80 70 continue if ( R2 >= RM) GO TO 230 R = (R2*(4-IR)+RM*(IR-1))/3.0D0 ! --------- 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.0D0 if ( ABS(ST) < ATOL) ST = 0.0D0 ZR = R*CT ZI = R*ST ! ------------- Cases for abs(Z).ge.FNU+N-1 if ( R >= GNU ) then ! ------------- Underflow - skip test for this case. call ZBESJ(ZR, ZI, FNU, KODE, N, VR, VI, NZ, IERR) if ( NZ /= 0) GO TO 210 call ZBESH(ZR, ZI, FNU, KODE, 1, N, WR, WI, NZ1, & IERR) call ZBESH(ZR, ZI, FNU, KODE, 2, N, YR, YI, NZ2, & IERR) ! --------------- Adjust scaling of H functions. if ( KODE == 2 ) then CC = -ZI - ABS(ZI) if ( CC > (-ALIM) ) then CWR = CC CWI = ZR call ZEXP(CWR, CWI, COE1R, COE1I) else COE1R = 0.0D0 COE1I = 0.0D0 end if DD = ZI - ABS(ZI) if ( DD > (-ALIM) ) then CWR = DD CWI = -ZR call ZEXP(CWR, CWI, COE2R, COE2I) else COE2R = 0.0D0 COE2I = 0.0D0 end if DO 130 KK = 1,N STR = YR(KK)*COE2R - YI(KK)*COE2I YI(KK) = YR(KK)*COE2I + YI(KK)*COE2R YR(KK) = STR STR = WR(KK)*COE1R - WI(KK)*COE1I WI(KK) = WR(KK)*COE1I + WI(KK)*COE1R WR(KK) = STR 130 continue end if ! ------------- Cases for abs(Z).lt.FNU+N-1 else M = N + 16 ! ------------- Underflow at end of sequence - skip test call ZBESJ(ZR, ZI, FNU, KODE, M, VR, VI, NZ, IERR) if ( NZ > 10) GO TO 210 call ZBESJ(ZR, ZI, FNU, KODE, N, WR, WI, NZ, IERR) DO 150 KK = 1,N YR(KK) = WR(KK) YI(KK) = WI(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=', D12.4/) write (LUN,99994) 99994 FORMAT (' INPUT TO ZBESJ 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 ZBESJ NZ, V(KK)') write (LUN,99991) 99991 FORMAT (' RESULTS FROM ZBESH NZ1, W(KK)') write (LUN,99990) 99990 FORMAT (' RESULTS FROM ZBESH NZ2, Y(KK)') else write (LUN,99989) 99989 FORMAT (' RESULTS FROM ZBESJ 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) ZR, ZI, FNU, KODE, N 99987 FORMAT (' INPUT: Z=',2D12.4,3X,'FNU=',D12.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)=',4D12.4) if ( R >= GNU ) then KK = max ( NZ1,NZ2) + 1 KK = min ( N,KK) write (LUN,99985) NZ, VR(KK), VI(KK) 99985 FORMAT (' RESULTS: NZ=',I3,3X,'V(KK)=',2D12.4) write (LUN,99984) NZ1, WR(KK), WI(KK) 99984 FORMAT (' RESULTS: NZ1=',I3,3X,'W(KK)=',2D12.4) write (LUN,99983) NZ2, YR(KK), YI(KK) 99983 FORMAT (' RESULTS: NZ2=',I3,3X,'Y(KK)=',2D12.4) else KK = N - NZ write (LUN,99982) NZ, WR(KK), WI(KK) 99982 FORMAT (' RESULTS: NZ=',I3,3X,'W(KK)=',2D12.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 ZBESJ 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 (/' ****** ZBESJ PASSED ALL TESTS ******'/) end if if ( ipass == 0 .and. KPRINT >= 1 ) then write (LUN,99977) 99977 FORMAT (/' ****** ZBESJ FAILED SOME TESTS ******'/) end if return end !! ZQCBK !***SUBSIDIARY !***PURPOSE Quick check for SLATEC subroutine ! ZBESK !***LIBRARY SLATEC !***CATEGORY C10B4 !***TYPE COMPLEX (CQCBK-C, ZQCBK-Z) !***KEYWORDS QUICK CHECK, ZBESK !***AUTHOR Amos, Don, (SNL) ! Goudy, Sue, (SNL) ! Walton, Lee, (SNL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call ZQCBK (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: ! ! *** A DOUBLE PRECISION ROUTINE *** ! ! ZQCBK is a quick check routine for the complex K Bessel function ! generated by subroutine ZBESK. ! ! ZQCBK generates sequences of I and K Bessel functions from ! ZBESI and ZBESK 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 ZBESI, ZBESK, ZABS, ZDIV, ZEXP, i1mach, d1mach !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890831 Revised to meet new SLATEC standard ! 930122 Added ZEXP to EXTERNAL Statement. (RWC) !***END PROLOGUE ZQCBK ! !*Internal Notes: ! Machine constants are defined by functions i1mach and d1mach. ! ! 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 ZQCBK (LUN, KPRINT, IPASS) integer MQC ! ! Declare arguments. ! PARAMETER (MQC=1) ! ! Declare external functions. ! integer LUN, KPRINT, IPASS integer i1mach double precision d1mach, ZABS ! ! Declare local variables. ! EXTERNAL i1mach, d1mach, ZABS, ZEXP double precision CONER,CONEI, CSGNR,CSGNI, CVR,CVI, CWR,CWI, & CYR,CYI, WR,WI, YR,YI, ZR,ZI, ZNR,ZNI double precision 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, STI, STR, T, TOL, TS, XNU 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), WR(20), WI(20), & ! !***FIRST EXECUTABLE STATEMENT ZQCBK XNU(20), YR(20), YI(20) if ( KPRINT >= 2 ) then write (LUN,99999) 99999 FORMAT (' QUICK CHECK ROUTINE FOR THE K BESSEL FUNCTION FROM ', & 'ZBESK'/) ! ! Set parameters related to machine constants. ! TOL is the approximate unit roundoff limited to 1.0D-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 = d1mach(4) TOL = max ( R1M4,1.0D-18) ATOL = 100.0D0*TOL AA = -LOG10(R1M4) K1 = i1mach(12) K2 = i1mach(13) R1M5 = d1mach(5) K = min ( ABS(K1),ABS(K2)) ELIM = 2.303D0*(K*R1M5-3.0D0) AB = AA*2.303D0 ALIM = ELIM + max ( -AB,-41.45D0) DIG = min ( AA,18.0D0) FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) RL = 1.2D0*DIG + 3.0D0 SLAK = 3.0D0+4.0D0*(-LOG10(TOL)-7.0D0)/11.0D0 SLAK = max ( SLAK,3.0D0) ERTOL = TOL*10.0D0**SLAK RM = 0.5D0*(ALIM + ELIM) RM = min ( RM,200.0D0) RM = max ( RM,RL+10.0D0) 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,6D12.4/) ! ! Set other constants needed in the tests. ! end if CONER = 1.0D0 CONEI = 0.0D0 HPI = 2.0D0*ATAN(1.0D0) ! ! 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 KEPS(1:il) = 0 KDO(1:il) = 0 NUL = 5 XNU(1) = 0.0D0 XNU(2) = 1.0D0 XNU(3) = 2.0D0 XNU(4) = 0.5D0*FNUL XNU(5) = FNUL + 1.1D0 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.0D0 XNU(2) = 0.6D0 XNU(3) = 1.3D0 XNU(4) = 2.0D0 XNU(5) = 0.5D0*FNUL XNU(6) = FNUL + 1.1D0 end if I = 2 EPS = 0.01D0 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 CSGNR = COS(ARG) CSGNI = SIN(ARG) if ( MOD(IFNU,2) == 1 ) then CSGNR = -CSGNR CSGNI = -CSGNI 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.0D0*(IR-1))/3.0D0 GO TO 80 60 continue R = (2.0D0*(4-IR)+R2*(IR-1))/3.0D0 GO TO 80 70 continue if ( R2 >= RM) GO TO 170 R = (R2*(4-IR)+RM*(IR-1))/3.0D0 ! --------- end switch 80 continue DO 150 IT = 1,ITL CT = COS(T(IT)) ST = SIN(T(IT)) if ( ABS(CT) < ATOL) CT = 0.0D0 if ( ABS(ST) < ATOL) ST = 0.0D0 ZR = R*CT ZI = R*ST ! ----------- Underflow? - skip test for this case. call ZBESI(ZR, ZI, FNU, KODE, N1, WR, WI, 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.0D0 ) then call ZBESK(ZR, ZI, FNU, KODE, N1, YR, YI, NZ1, IERR) call ZDIV(CONER, CONEI, ZR, ZI, CVR, CVI) ! --------------- Adjust Wronskian due to scaled I and K functions if ( KODE == 2 ) then AXX = ABS(ZR) ZNR = -AXX ZNI = 0.0D0 CVR = ZNR + ZR CVI = ZNI + ZI call ZEXP(CVR, CVI, STR, STI) call ZDIV(STR, STI, ZR, ZI, CVR, CVI) end if ! ------------- Z is in the left half plane else ZNR = -ZR ZNI = -ZI call ZBESK(ZNR, ZNI, FNU, KODE, N1, YR, YI, NZ1, & IERR) ZNR = CSGNR ! ------------- CSGNR and CSGNI set near top of DO 180 loop ZNI = CSGNI if ( ST > 0.0D0 .OR. (ST == 0.0D0 .and. CT < 0.0D0)) & ZNI = -ZNI DO 90 KK = 1,N1 STR = YR(KK)*ZNR - YI(KK)*ZNI YI(KK) = YR(KK)*ZNI + YI(KK)*ZNR YR(KK) = STR ZNR = -ZNR ZNI = -ZNI 90 continue call ZDIV(CONER, CONEI, ZR, ZI, CVR, CVI) ! ! Adjust Wronskian due to scaled I and K functions ! if ( KODE == 2 ) then AXX = ABS(ZR) ZNR = -AXX ZNI = 0.0D0 CVR = ZNR - ZR CVI = ZNI - ZI call ZEXP(CVR, CVI, STR, STI) call ZDIV(STR, STI, ZR, ZI, CVR, CVI) end if end if MFLG = 0 DO 130 I = 1,N CWR = WR(I)*YR(I+1) - WI(I)*YI(I+1) CWI = WR(I)*YI(I+1) + WI(I)*YR(I+1) CYR = WR(I+1)*YR(I) - WI(I+1)*YI(I) CYI = WR(I+1)*YI(I) + WI(I+1)*YR(I) CYR = CYR + CWR - CVR CYI = CYI + CWI - CVI ER = ZABS(CYR,CYI)/ZABS(CVR,CVI) 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 = ',D12.4/) write (LUN,99994) 99994 FORMAT (' INPUT TO ZBESK Z, FNU, KODE, N') end if if ( KPRINT >= 3 ) then write (LUN,99993) 99993 FORMAT (' ERROR TEST ON THE WRONSKIAN OF ', & 'ZBESI(Z,FNU) AND ZBESK(Z,FNU)') write (LUN,99992) 99992 FORMAT (' RESULTS FROM ZBESK NZ1, Y(KK)'/, & ' RESULTS FROM ZBESI 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) ZR, ZI, FNU, KODE, N 99990 FORMAT (' INPUT: Z=',2D12.4,4X,'FNU=',D12.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)=',4D12.4) KK = max ( NZ1,NZ2) + 1 KK = min ( N,KK) write (LUN,99988) NZ1, YR(KK), YI(KK), & NZ2, WR(KK), WI(KK) 99988 FORMAT (' RESULTS: NZ1=',I3,4X,'Y(KK)=',2D12.4, & /11X,'NZ2=',I3,4X,'W(KK)=',2D12.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 ZBESK 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 (/' ****** ZBESK PASSED ALL TESTS ******'/) end if if ( ipass == 0 .and. KPRINT >= 1 ) then write (LUN,99983) 99983 FORMAT (/' ****** ZBESK FAILED SOME TESTS ******'/) end if return END subroutine ZQCBY (LUN, KPRINT, IPASS) ! !! ZQCBY !***SUBSIDIARY !***PURPOSE Quick check for SLATEC subroutine ! ZBESY !***LIBRARY SLATEC !***CATEGORY C10A4 !***TYPE COMPLEX (CQCBY-C, ZQCBY-Z) !***KEYWORDS QUICK CHECK, ZBESY !***AUTHOR Amos, Don, (SNL) ! Goudy, Sue, (SNL) ! Walton, Lee, (SNL) !***DESCRIPTION ! ! *Usage: ! ! INTEGER LUN, KPRINT, IPASS ! ! call ZQCBY (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: ! ! *** A DOUBLE PRECISION ROUTINE *** ! ! ZQCBY is a quick check routine for the complex Y Bessel function ! generated by subroutine ZBESY. ! ! ZQCBY generates sequences of Y Bessel functions from ZBESY ! 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 ZBESI, ZBESK, ZBESY, ZABS, ZEXP, i1mach, d1mach !***REVISION HISTORY (YYMMDD) ! 830501 DATE WRITTEN ! 890831 Revised to meet new SLATEC standards ! 930122 Added ZEXP to EXTERNAL Statement. (RWC) !***END PROLOGUE ZQCBY ! !*Internal Notes: ! Machine constants are defined by functions i1mach and d1mach. ! ! 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. ! integer MQC ! ! Declare arguments. ! PARAMETER (MQC=1) ! ! Declare external functions. ! integer LUN, KPRINT, IPASS integer i1mach double precision d1mach, ZABS ! ! Declare local variables. ! EXTERNAL i1mach, d1mach, ZABS, ZEXP double precision CIPR,CIPI, COE1R,COE1I, COE2R,COE2I, & CSGNR,CSGNI, CSPNR,CSPNI, CWR,CWI, CWRKR,CWRKI, VR,VI, WR,WI, & YR,YI, ZR,ZI, ZNR,ZNI double precision AA, AB, AER, AI, ALIM, AR, ARG, ATOL, AV, CC, & CT, DIG, ELIM, EPS, ER, ERTOL, FFNU, FILM, FNU, FNUL, HPI, PI, & PTR, R, RHPI, RL, RM, R1M4, R1M5, R2, SLAK, ST, STI, STR, T, & TOL, TS, XNU 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), CIPR(4), CIPI(4), CWRKR(20), CWRKI(20), & KDO(20), KEPS(20), T(20), VR(20), VI(20), WR(20), WI(20), & XNU(20), YR(20), YI(20) DATA CIPR(1), CIPI(1), CIPR(2), CIPI(2), CIPR(3), CIPI(3), & CIPR(4), CIPI(4) / 1.0D0,0.0D0, 0.0D0,1.0D0, -1.0D0,0.0D0, & ! !***FIRST EXECUTABLE STATEMENT ZQCBY 0.0D0,-1.0D0 / if ( KPRINT >= 2 ) then write (LUN,99999) 99999 FORMAT (' QUICK CHECK ROUTINE FOR THE Y BESSEL FUNCTION FROM ', & 'ZBESY'/) ! ------------------------------------------------------------------ ! Set parameters related to machine constants. ! TOL is the approximate unit roundoff limited to 1.0D-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 = d1mach(4) TOL = max ( R1M4,1.0D-18) ATOL = 100.0D0*TOL AA = -LOG10(R1M4) K1 = i1mach(12) K2 = i1mach(13) R1M5 = d1mach(5) K = min ( ABS(K1),ABS(K2)) ELIM = 2.303D0*(K*R1M5-3.0D0) AB = AA*2.303D0 ALIM = ELIM + max ( -AB,-41.45D0) DIG = min ( AA,18.0D0) FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) RL = 1.2D0*DIG + 3.0D0 SLAK = 3.0D0+4.0D0*(-LOG10(TOL)-7.0D0)/11.0D0 SLAK = max ( SLAK,3.0D0) ERTOL = TOL*10.0D0**SLAK RM = 0.5D0*(ALIM + ELIM) RM = min ( RM,200.0D0) RM = max ( RM,RL+10.0D0) 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,6D12.4/) ! ------------------------------------------------------------------ ! Set other constants needed in the tests. ! ------------------------------------------------------------------ end if HPI = 2.0D0*ATAN(1.0D0) RHPI = 1.0D0/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.0D0 XNU(2) = 1.0D0 XNU(3) = 2.0D0 XNU(4) = 0.5D0*FNUL XNU(5) = FNUL + 1.2D0 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.0D0 XNU(2) = 0.6D0 XNU(3) = 1.3D0 XNU(4) = 2.0D0 XNU(5) = 0.5D0*FNUL XNU(6) = FNUL + 1.2D0 end if I = 2 EPS = 0.01D0 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 CSGNR = COS(ARG) CSGNI = SIN(ARG) I4 = MOD(IFNU,4) + 1 STR = CSGNR*CIPR(I4) - CSGNI*CIPI(I4) CSGNI = CSGNR*CIPI(I4) + CSGNI*CIPR(I4) CSGNR = STR CSPNR = CSGNR*RHPI ! ----- CSGN=CSGN*CI in CQCBY CSPNI = -CSGNI*RHPI STR = -CSGNI CSGNI = CSGNR CSGNR = STR 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.0D0*(IR-1))/3.0D0 GO TO 80 60 continue R = (2.0D0*(4-IR)+R2*(IR-1))/3.0D0 GO TO 80 70 continue if ( R2 >= RM) GO TO 160 R = (R2*(4-IR)+RM*(IR-1))/3.0D0 ! --------- end switch 80 continue DO 140 IT = 1,ITL CT = COS(T(IT)) ST = SIN(T(IT)) if ( ABS(CT) < ATOL) CT = 0.0D0 if ( ABS(ST) < ATOL) ST = 0.0D0 ZR = R*CT ZI = R*ST ! ----------- Underflow in ZBESI - skip test for this case. call ZBESI(ZR, ZI, FNU, KODE, N, WR, WI, NZ2, IERR) if ( NZ2 /= 0) GO TO 140 ! ----------- Underflow in ZBESK - skip test for this case. call ZBESK(ZR, ZI, FNU, KODE, N, YR, YI, NZ1, IERR) if ( NZ1 /= 0) GO TO 140 ZNR = -ZI ZNI = ZR call ZBESY(ZNR, ZNI, FNU, KODE, N, VR, VI, NZ, CWRKR, & ! ! Underflow in ZBESY - skip test for this case. ! CWRKI, IERR) if ( NZ /= 0) GO TO 140 COE1R = CSGNR COE1I = CSGNI COE2R = CSPNR COE2I = CSPNI ! ! Adjust scale for I and K functions. ! if ( KODE == 2 ) then CC = -ZR - ABS(ZR) if ( CC > (-ALIM) ) then ZNR = CC ZNI = -ZI call ZEXP(ZNR, ZNI, STR, STI) PTR = STR*COE2R - STI*COE2I COE2I = STR*COE2I + STI*COE2R COE2R = PTR ! ! Scaling problem - skip test for this case ! else COE2R = 0.0D0 COE2I = 0.0D0 GO TO 140 end if end if DO 110 KK = 1,N STR = YR(KK)*COE2R - YI(KK)*COE2I YI(KK) = YR(KK)*COE2I + YI(KK)*COE2R YR(KK) = STR STR = WR(KK)*COE1R - WI(KK)*COE1I WI(KK) = WR(KK)*COE1I + WI(KK)*COE1R WR(KK) = STR STR = -COE1I COE1I = COE1R COE1R = STR STR = COE2I COE2I = -COE2R COE2R = STR ! ------------------------------------------------------------------ ! 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.5D0,AB) CWR = WR(I) - YR(I) CWI = WI(I) - YI(I) AV = ZABS(VR(I),VI(I)) AR = CWR - VR(I) AI = CWI - VI(I) ER = ZABS(AR,AI) if ( AV /= 0.0D0 ) then if ( ZNI == 0.0D0 ) then if ( ZNR > 0.0D0 ) then if ( DABS(ZNR) < AA) ER = ER/AV else if ( DABS(FFNU-0.5D0) < 0.125D0 ) then if ( DABS(ZNR) < 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 = ',D12.4/) write (LUN,99994) 99994 FORMAT (' INPUT TO ZBESY 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 ZBESY V(KK)'/ & 9X,'FROM ZBESI W(KK)'/ & 9X,'FROM ZBESK 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) ZNR, ZNI, FNU, KODE, N 99989 FORMAT (' INPUT: ZN=',2D12.4,3X,'FNU=',D12.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)=',4D12.4) write (LUN,99987) ZR, ZI, COE1R, COE1I, COE2R, & COE2R 99987 FORMAT (12X,'Z=',2D12.4/12X,'COE1=',2D12.4,3X, & 'COE2=',2D12.4) KK = max ( NZ1,NZ2) + 1 KK = min ( N,KK) write (LUN,99986) VR(KK), VI(KK), WR(KK), WI(KK), & YR(KK), YI(KK) 99986 FORMAT (' RESULTS: V(KK)=',2D12.4/ & 12X,'W(KK)=',2D12.4/12X,'Y(KK)=',2D12.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 ZBESY 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 (/' ****** ZBESY PASSED ALL TESTS ******'/) end if if ( ipass == 0 .and. KPRINT >= 1 ) then write (LUN,99981) 99981 FORMAT (/' ****** ZBESY FAILED SOME TESTS ******'/) end if return end