From bbb5eed396821f9f68271d27a92edc8a3e759f13 Mon Sep 17 00:00:00 2001 From: Ray Speth Date: Wed, 13 Apr 2016 18:28:51 -0400 Subject: [PATCH] Remove unnused code from 'ext' --- ext/blas/dasum.f | 43 - ext/blas/daxpy.f | 48 - ext/blas/dcabs1.f | 8 - ext/blas/dcopy.f | 50 - ext/blas/ddot.f | 49 - ext/blas/dgbmv.f | 300 - ext/blas/dgemm.f | 313 -- ext/blas/dgemv.f | 261 - ext/blas/dger.f | 157 - ext/blas/dnrm2.f | 60 - ext/blas/drot.f | 37 - ext/blas/drotg.f | 27 - ext/blas/drotm.f | 108 - ext/blas/drotmg.f | 169 - ext/blas/dsbmv.f | 303 -- ext/blas/dscal.f | 43 - ext/blas/dsdot.f | 74 - ext/blas/dspmv.f | 262 - ext/blas/dspr.f | 198 - ext/blas/dspr2.f | 229 - ext/blas/dswap.f | 56 - ext/blas/dsymm.f | 294 - ext/blas/dsymv.f | 262 - ext/blas/dsyr.f | 197 - ext/blas/dsyr2.f | 230 - ext/blas/dsyr2k.f | 327 -- ext/blas/dsyrk.f | 294 - ext/blas/dtbmv.f | 342 -- ext/blas/dtbsv.f | 346 -- ext/blas/dtpmv.f | 299 - ext/blas/dtpsv.f | 302 - ext/blas/dtrmm.f | 355 -- ext/blas/dtrmv.f | 286 - ext/blas/dtrsm.f | 378 -- ext/blas/dtrsv.f | 289 - ext/blas/dzasum.f | 34 - ext/blas/dznrm2.f | 67 - ext/blas/icamax.f | 43 - ext/blas/idamax.f | 39 - ext/blas/isamax.f | 39 - ext/blas/izamax.f | 41 - ext/blas/xerbla.f | 43 - ext/f2c_blas/blaswrap.h | 162 - ext/f2c_blas/dasum.c | 73 - ext/f2c_blas/daxpy.c | 91 - ext/f2c_blas/dcabs1.c | 24 - ext/f2c_blas/dcopy.c | 79 - ext/f2c_blas/ddot.c | 82 - ext/f2c_blas/dgbmv.c | 307 -- ext/f2c_blas/dgemm.c | 319 -- ext/f2c_blas/dgemv.c | 251 - ext/f2c_blas/dger.c | 149 - ext/f2c_blas/dnrm2.c | 68 - ext/f2c_blas/drot.c | 62 - ext/f2c_blas/drotg.c | 57 - ext/f2c_blas/drotm.c | 183 - ext/f2c_blas/drotmg.c | 265 - ext/f2c_blas/dsbmv.c | 299 - ext/f2c_blas/dscal.c | 62 - ext/f2c_blas/dsdot.c | 122 - ext/f2c_blas/dspmv.c | 250 - ext/f2c_blas/dspr.c | 185 - ext/f2c_blas/dspr2.c | 216 - ext/f2c_blas/dswap.c | 87 - ext/f2c_blas/dsymm.c | 298 - ext/f2c_blas/dsymv.c | 256 - ext/f2c_blas/dsyr.c | 185 - ext/f2c_blas/dsyr2.c | 226 - ext/f2c_blas/dsyr2k.c | 340 -- ext/f2c_blas/dsyrk.c | 310 -- ext/f2c_blas/dtbmv.c | 354 -- ext/f2c_blas/dtbsv.c | 357 -- ext/f2c_blas/dtpmv.c | 296 - ext/f2c_blas/dtpsv.c | 298 - ext/f2c_blas/dtrmm.c | 381 -- ext/f2c_blas/dtrmv.c | 283 - ext/f2c_blas/dtrsm.c | 410 -- ext/f2c_blas/dtrsv.c | 285 - ext/f2c_blas/dzasum.c | 55 - ext/f2c_blas/dznrm2.c | 82 - ext/f2c_blas/idamax.c | 74 - ext/f2c_blas/isamax.c | 88 - ext/f2c_blas/lsame.c | 107 - ext/f2c_blas/xerbla.c | 50 - ext/f2c_lapack/blaswrap.h | 159 - ext/f2c_lapack/dbdsqr.c | 906 --- ext/f2c_lapack/dgbcon.c | 283 - ext/f2c_lapack/dgbequ.c | 321 -- ext/f2c_lapack/dgbrfs.c | 433 -- ext/f2c_lapack/dgbsv.c | 161 - ext/f2c_lapack/dgbtf2.c | 247 - ext/f2c_lapack/dgbtrf.c | 570 -- ext/f2c_lapack/dgbtrs.c | 229 - ext/f2c_lapack/dgebak.c | 220 - ext/f2c_lapack/dgebal.c | 386 -- ext/f2c_lapack/dgebd2.c | 284 - ext/f2c_lapack/dgebrd.c | 326 -- ext/f2c_lapack/dgecon.c | 228 - ext/f2c_lapack/dgeequ.c | 297 - ext/f2c_lapack/dgelq2.c | 142 - ext/f2c_lapack/dgelqf.c | 242 - ext/f2c_lapack/dgels.c | 480 -- ext/f2c_lapack/dgelss.c | 818 --- ext/f2c_lapack/dgeqr2.c | 146 - ext/f2c_lapack/dgeqrf.c | 243 - ext/f2c_lapack/dgerfs.c | 420 -- ext/f2c_lapack/dgetf2.c | 163 - ext/f2c_lapack/dgetrf.c | 203 - ext/f2c_lapack/dgetri.c | 249 - ext/f2c_lapack/dgetrs.c | 165 - ext/f2c_lapack/dlabad.c | 62 - ext/f2c_lapack/dlabrd.c | 418 -- ext/f2c_lapack/dlacon.c | 257 - ext/f2c_lapack/dlacpy.c | 114 - ext/f2c_lapack/dlamch.c | 975 ---- ext/f2c_lapack/dlange.c | 182 - ext/f2c_lapack/dlantr.c | 401 -- ext/f2c_lapack/dlapy2.c | 57 - ext/f2c_lapack/dlarf.c | 138 - ext/f2c_lapack/dlarfb.c | 711 --- ext/f2c_lapack/dlarfg.c | 155 - ext/f2c_lapack/dlarft.c | 264 - ext/f2c_lapack/dlartg.c | 165 - ext/f2c_lapack/dlas2.c | 128 - ext/f2c_lapack/dlascl.c | 319 -- ext/f2c_lapack/dlaset.c | 139 - ext/f2c_lapack/dlasq1.c | 199 - ext/f2c_lapack/dlasq2.c | 529 -- ext/f2c_lapack/dlasq3.c | 323 -- ext/f2c_lapack/dlasq4.c | 387 -- ext/f2c_lapack/dlasq5.c | 216 - ext/f2c_lapack/dlasq6.c | 194 - ext/f2c_lapack/dlasr.c | 400 -- ext/f2c_lapack/dlasrt.c | 266 - ext/f2c_lapack/dlassq.c | 99 - ext/f2c_lapack/dlasv2.c | 256 - ext/f2c_lapack/dlaswp.c | 149 - ext/f2c_lapack/dlatbs.c | 855 --- ext/f2c_lapack/dlatrs.c | 820 --- ext/f2c_lapack/dorg2r.c | 160 - ext/f2c_lapack/dorgbr.c | 285 - ext/f2c_lapack/dorgl2.c | 160 - ext/f2c_lapack/dorglq.c | 269 - ext/f2c_lapack/dorgqr.c | 271 - ext/f2c_lapack/dorm2r.c | 221 - ext/f2c_lapack/dormbr.c | 348 -- ext/f2c_lapack/dorml2.c | 217 - ext/f2c_lapack/dormlq.c | 322 -- ext/f2c_lapack/dormqr.c | 314 -- ext/f2c_lapack/dpotf2.c | 224 - ext/f2c_lapack/dpotrf.c | 254 - ext/f2c_lapack/dpotrs.c | 171 - ext/f2c_lapack/drscl.c | 114 - ext/f2c_lapack/dtrcon.c | 242 - ext/f2c_lapack/dtrti2.c | 166 - ext/f2c_lapack/dtrtri.c | 225 - ext/f2c_lapack/dtrtrs.c | 187 - ext/f2c_lapack/ieeeck.c | 156 - ext/f2c_lapack/ilaenv.c | 616 --- ext/f2c_libs/.gitignore | 1 - ext/f2c_libs/abort_.c | 22 - ext/f2c_libs/arithchk/arithchk.c | 225 - ext/f2c_libs/backspac.c | 76 - ext/f2c_libs/c_abs.c | 20 - ext/f2c_libs/c_cos.c | 23 - ext/f2c_libs/c_div.c | 53 - ext/f2c_libs/c_exp.c | 25 - ext/f2c_libs/c_log.c | 23 - ext/f2c_libs/c_sin.c | 23 - ext/f2c_libs/c_sqrt.c | 42 - ext/f2c_libs/cabs.c | 33 - ext/f2c_libs/close.c | 101 - ext/f2c_libs/d_abs.c | 18 - ext/f2c_libs/d_acos.c | 19 - ext/f2c_libs/d_asin.c | 19 - ext/f2c_libs/d_atan.c | 19 - ext/f2c_libs/d_atn2.c | 19 - ext/f2c_libs/d_cnjg.c | 19 - ext/f2c_libs/d_cos.c | 19 - ext/f2c_libs/d_cosh.c | 19 - ext/f2c_libs/d_dim.c | 16 - ext/f2c_libs/d_exp.c | 19 - ext/f2c_libs/d_imag.c | 16 - ext/f2c_libs/d_int.c | 19 - ext/f2c_libs/d_lg10.c | 21 - ext/f2c_libs/d_log.c | 19 - ext/f2c_libs/d_mod.c | 46 - ext/f2c_libs/d_nint.c | 20 - ext/f2c_libs/d_prod.c | 16 - ext/f2c_libs/d_sign.c | 18 - ext/f2c_libs/d_sin.c | 19 - ext/f2c_libs/d_sinh.c | 19 - ext/f2c_libs/d_sqrt.c | 19 - ext/f2c_libs/d_tan.c | 19 - ext/f2c_libs/d_tanh.c | 19 - ext/f2c_libs/dfe.c | 151 - ext/f2c_libs/dolio.c | 26 - ext/f2c_libs/dtime_.c | 63 - ext/f2c_libs/due.c | 77 - ext/f2c_libs/ef1asc_.c | 25 - ext/f2c_libs/ef1cmc_.c | 20 - ext/f2c_libs/endfile.c | 160 - ext/f2c_libs/err.c | 291 - ext/f2c_libs/etime_.c | 58 - ext/f2c_libs/exit_.c | 43 - ext/f2c_libs/f2c.h | 246 - ext/f2c_libs/f2c.h0 | 246 - ext/f2c_libs/f2ch.add | 162 - ext/f2c_libs/f77_aloc.c | 44 - ext/f2c_libs/f77vers.c | 93 - ext/f2c_libs/fio.h | 153 - ext/f2c_libs/fmt.c | 525 -- ext/f2c_libs/fmt.h | 104 - ext/f2c_libs/fmtlib.c | 51 - ext/f2c_libs/fp.h | 28 - ext/f2c_libs/ftell_.c | 52 - ext/f2c_libs/getenv_.c | 64 - ext/f2c_libs/h_abs.c | 18 - ext/f2c_libs/h_dim.c | 16 - ext/f2c_libs/h_dnnt.c | 19 - ext/f2c_libs/h_indx.c | 32 - ext/f2c_libs/h_len.c | 16 - ext/f2c_libs/h_mod.c | 16 - ext/f2c_libs/h_nint.c | 19 - ext/f2c_libs/h_sign.c | 18 - ext/f2c_libs/hl_ge.c | 18 - ext/f2c_libs/hl_gt.c | 18 - ext/f2c_libs/hl_le.c | 18 - ext/f2c_libs/hl_lt.c | 18 - ext/f2c_libs/i77vers.c | 343 -- ext/f2c_libs/i_abs.c | 18 - ext/f2c_libs/i_dim.c | 16 - ext/f2c_libs/i_dnnt.c | 19 - ext/f2c_libs/i_indx.c | 32 - ext/f2c_libs/i_len.c | 16 - ext/f2c_libs/i_mod.c | 16 - ext/f2c_libs/i_nint.c | 19 - ext/f2c_libs/i_sign.c | 18 - ext/f2c_libs/iio.c | 159 - ext/f2c_libs/ilnw.c | 83 - ext/f2c_libs/inquire.c | 132 - ext/f2c_libs/l_ge.c | 18 - ext/f2c_libs/l_gt.c | 18 - ext/f2c_libs/l_le.c | 18 - ext/f2c_libs/l_lt.c | 18 - ext/f2c_libs/lbitbits.c | 68 - ext/f2c_libs/lbitshft.c | 17 - ext/f2c_libs/lio.h | 74 - ext/f2c_libs/lread.c | 809 --- ext/f2c_libs/lwrite.c | 314 -- ext/f2c_libs/open.c | 299 - ext/f2c_libs/pow_ci.c | 26 - ext/f2c_libs/pow_dd.c | 19 - ext/f2c_libs/pow_di.c | 41 - ext/f2c_libs/pow_hh.c | 39 - ext/f2c_libs/pow_ii.c | 39 - ext/f2c_libs/pow_ri.c | 41 - ext/f2c_libs/pow_zi.c | 60 - ext/f2c_libs/pow_zz.c | 29 - ext/f2c_libs/r_abs.c | 18 - ext/f2c_libs/r_acos.c | 19 - ext/f2c_libs/r_asin.c | 19 - ext/f2c_libs/r_atan.c | 19 - ext/f2c_libs/r_atn2.c | 19 - ext/f2c_libs/r_cnjg.c | 18 - ext/f2c_libs/r_cos.c | 19 - ext/f2c_libs/r_cosh.c | 19 - ext/f2c_libs/r_dim.c | 16 - ext/f2c_libs/r_exp.c | 19 - ext/f2c_libs/r_imag.c | 16 - ext/f2c_libs/r_int.c | 19 - ext/f2c_libs/r_lg10.c | 21 - ext/f2c_libs/r_log.c | 19 - ext/f2c_libs/r_mod.c | 46 - ext/f2c_libs/r_nint.c | 20 - ext/f2c_libs/r_sign.c | 18 - ext/f2c_libs/r_sin.c | 19 - ext/f2c_libs/r_sinh.c | 19 - ext/f2c_libs/r_sqrt.c | 19 - ext/f2c_libs/r_tan.c | 19 - ext/f2c_libs/r_tanh.c | 19 - ext/f2c_libs/rawio.h | 41 - ext/f2c_libs/rdfmt.c | 550 -- ext/f2c_libs/rewind.c | 30 - ext/f2c_libs/rsfe.c | 91 - ext/f2c_libs/rsli.c | 109 - ext/f2c_libs/rsne.c | 618 --- ext/f2c_libs/s_cat.c | 86 - ext/f2c_libs/s_cmp.c | 50 - ext/f2c_libs/s_copy.c | 57 - ext/f2c_libs/s_rnge.c | 32 - ext/f2c_libs/s_stop.c | 48 - ext/f2c_libs/sfe.c | 43 - ext/f2c_libs/sig_die.c | 51 - ext/f2c_libs/signal1.h | 35 - ext/f2c_libs/signal_.c | 21 - ext/f2c_libs/signbit.c | 24 - ext/f2c_libs/sue.c | 90 - ext/f2c_libs/sysdep1.h | 78 - ext/f2c_libs/system_.c | 42 - ext/f2c_libs/typesize.c | 18 - ext/f2c_libs/uio.c | 75 - ext/f2c_libs/uninit.c | 368 -- ext/f2c_libs/util.c | 69 - ext/f2c_libs/wref.c | 294 - ext/f2c_libs/wrtfmt.c | 377 -- ext/f2c_libs/wsfe.c | 78 - ext/f2c_libs/wsle.c | 42 - ext/f2c_libs/wsne.c | 32 - ext/f2c_libs/xwsne.c | 77 - ext/f2c_libs/z_abs.c | 18 - ext/f2c_libs/z_cos.c | 21 - ext/f2c_libs/z_div.c | 50 - ext/f2c_libs/z_exp.c | 23 - ext/f2c_libs/z_log.c | 121 - ext/f2c_libs/z_sin.c | 21 - ext/f2c_libs/z_sqrt.c | 35 - ext/f2c_math/cblas.h | 646 --- ext/f2c_math/daux.c | 345 -- ext/f2c_math/ddaspk.c | 8774 ------------------------------ ext/f2c_math/dgbefa.c | 240 - ext/f2c_math/dgbsl.c | 193 - ext/f2c_math/dgefa.c | 151 - ext/f2c_math/dgesl.c | 170 - ext/f2c_math/dp1vlu.c | 248 - ext/f2c_math/dpcoef.c | 114 - ext/f2c_math/dpolft.c | 526 -- ext/f2c_math/fdump.c | 40 - ext/f2c_math/j4save.c | 78 - ext/f2c_math/mach.cpp | 88 - ext/f2c_math/pcoef.c | 993 ---- ext/f2c_math/polfit.c | 404 -- ext/f2c_math/printstring.c | 5 - ext/f2c_math/pvalue.c | 211 - ext/f2c_math/xercnt.c | 70 - ext/f2c_math/xerhlt.c | 65 - ext/f2c_math/xermsg.c | 464 -- ext/f2c_math/xerprn.c | 289 - ext/f2c_math/xersve.c | 227 - ext/f2c_math/xgetua.c | 80 - ext/lapack/dbdsqr.f | 807 --- ext/lapack/dgbcon.f | 222 - ext/lapack/dgbequ.f | 240 - ext/lapack/dgbsv.f | 144 - ext/lapack/dgbtf2.f | 203 - ext/lapack/dgbtrf.f | 442 -- ext/lapack/dgbtrs.f | 187 - ext/lapack/dgebd2.f | 238 - ext/lapack/dgebrd.f | 258 - ext/lapack/dgecon.f | 181 - ext/lapack/dgeequ.f | 226 - ext/lapack/dgelq2.f | 122 - ext/lapack/dgelqf.f | 186 - ext/lapack/dgelss.f | 604 -- ext/lapack/dgeqr2.f | 122 - ext/lapack/dgeqrf.f | 187 - ext/lapack/dgerfs.f | 332 -- ext/lapack/dgetf2.f | 135 - ext/lapack/dgetrf.f | 160 - ext/lapack/dgetri.f | 801 --- ext/lapack/dgetrs.f | 150 - ext/lapack/dlabad.f | 56 - ext/lapack/dlabrd.f | 291 - ext/lapack/dlacon.f | 204 - ext/lapack/dlacpy.f | 88 - ext/lapack/dlamch.f | 857 --- ext/lapack/dlange.f | 145 - ext/lapack/dlantr.f | 277 - ext/lapack/dlapy2.f | 54 - ext/lapack/dlarf.f | 116 - ext/lapack/dlarfb.f | 588 -- ext/lapack/dlarfg.f | 138 - ext/lapack/dlarft.f | 218 - ext/lapack/dlartg.f | 143 - ext/lapack/dlas2.f | 122 - ext/lapack/dlascl.f | 268 - ext/lapack/dlaset.f | 115 - ext/lapack/dlasq1.f | 222 - ext/lapack/dlasq2.f | 268 - ext/lapack/dlasq3.f | 820 --- ext/lapack/dlasq4.f | 103 - ext/lapack/dlasr.f | 325 -- ext/lapack/dlasrt.f | 244 - ext/lapack/dlassq.f | 89 - ext/lapack/dlasv2.f | 250 - ext/lapack/dlaswp.f | 120 - ext/lapack/dlatbs.f | 724 --- ext/lapack/dlatrs.f | 702 --- ext/lapack/dorg2r.f | 130 - ext/lapack/dorgbr.f | 223 - ext/lapack/dorgl2.f | 134 - ext/lapack/dorglq.f | 207 - ext/lapack/dorgqr.f | 208 - ext/lapack/dorm2r.f | 198 - ext/lapack/dormbr.f | 250 - ext/lapack/dorml2.f | 198 - ext/lapack/dormlq.f | 254 - ext/lapack/dormqr.f | 247 - ext/lapack/dpotf2.f | 168 - ext/lapack/dpotrf.f | 184 - ext/lapack/dpotrs.f | 133 - ext/lapack/drscl.f | 115 - ext/lapack/dtrcon.f | 193 - ext/lapack/dtrtrs.f | 148 - ext/lapack/ilaenv.f | 506 -- ext/lapack/lsame.f | 87 - ext/math/daux.f | 257 - ext/math/ddaspk.f | 6612 ---------------------- ext/math/dgbfa.f | 174 - ext/math/dgbsl.f | 135 - ext/math/dgefa.f | 104 - ext/math/dgesl.f | 117 - ext/math/dp1vlu.f | 151 - ext/math/dpcoef.f | 78 - ext/math/dpolft.f | 364 -- ext/math/fdump.f | 72 - ext/math/j4save.f | 65 - ext/math/mach.cpp | 88 - ext/math/pcoef.f | 712 --- ext/math/polfit.f | 289 - ext/math/printstring.c | 11 - ext/math/pvalue.f | 150 - ext/math/xercnt.f | 60 - ext/math/xerhlt.f | 40 - ext/math/xermsg.f | 364 -- ext/math/xerprn.f | 230 - ext/math/xersve.f | 155 - ext/math/xgetua.f | 51 - 428 files changed, 90731 deletions(-) delete mode 100644 ext/blas/dasum.f delete mode 100644 ext/blas/daxpy.f delete mode 100644 ext/blas/dcabs1.f delete mode 100644 ext/blas/dcopy.f delete mode 100644 ext/blas/ddot.f delete mode 100644 ext/blas/dgbmv.f delete mode 100644 ext/blas/dgemm.f delete mode 100644 ext/blas/dgemv.f delete mode 100644 ext/blas/dger.f delete mode 100644 ext/blas/dnrm2.f delete mode 100644 ext/blas/drot.f delete mode 100644 ext/blas/drotg.f delete mode 100644 ext/blas/drotm.f delete mode 100644 ext/blas/drotmg.f delete mode 100644 ext/blas/dsbmv.f delete mode 100644 ext/blas/dscal.f delete mode 100644 ext/blas/dsdot.f delete mode 100644 ext/blas/dspmv.f delete mode 100644 ext/blas/dspr.f delete mode 100644 ext/blas/dspr2.f delete mode 100644 ext/blas/dswap.f delete mode 100644 ext/blas/dsymm.f delete mode 100644 ext/blas/dsymv.f delete mode 100644 ext/blas/dsyr.f delete mode 100644 ext/blas/dsyr2.f delete mode 100644 ext/blas/dsyr2k.f delete mode 100644 ext/blas/dsyrk.f delete mode 100644 ext/blas/dtbmv.f delete mode 100644 ext/blas/dtbsv.f delete mode 100644 ext/blas/dtpmv.f delete mode 100644 ext/blas/dtpsv.f delete mode 100644 ext/blas/dtrmm.f delete mode 100644 ext/blas/dtrmv.f delete mode 100644 ext/blas/dtrsm.f delete mode 100644 ext/blas/dtrsv.f delete mode 100644 ext/blas/dzasum.f delete mode 100644 ext/blas/dznrm2.f delete mode 100644 ext/blas/icamax.f delete mode 100644 ext/blas/idamax.f delete mode 100644 ext/blas/isamax.f delete mode 100644 ext/blas/izamax.f delete mode 100644 ext/blas/xerbla.f delete mode 100644 ext/f2c_blas/blaswrap.h delete mode 100644 ext/f2c_blas/dasum.c delete mode 100644 ext/f2c_blas/daxpy.c delete mode 100644 ext/f2c_blas/dcabs1.c delete mode 100644 ext/f2c_blas/dcopy.c delete mode 100644 ext/f2c_blas/ddot.c delete mode 100644 ext/f2c_blas/dgbmv.c delete mode 100644 ext/f2c_blas/dgemm.c delete mode 100644 ext/f2c_blas/dgemv.c delete mode 100644 ext/f2c_blas/dger.c delete mode 100644 ext/f2c_blas/dnrm2.c delete mode 100644 ext/f2c_blas/drot.c delete mode 100644 ext/f2c_blas/drotg.c delete mode 100644 ext/f2c_blas/drotm.c delete mode 100644 ext/f2c_blas/drotmg.c delete mode 100644 ext/f2c_blas/dsbmv.c delete mode 100644 ext/f2c_blas/dscal.c delete mode 100644 ext/f2c_blas/dsdot.c delete mode 100644 ext/f2c_blas/dspmv.c delete mode 100644 ext/f2c_blas/dspr.c delete mode 100644 ext/f2c_blas/dspr2.c delete mode 100644 ext/f2c_blas/dswap.c delete mode 100644 ext/f2c_blas/dsymm.c delete mode 100644 ext/f2c_blas/dsymv.c delete mode 100644 ext/f2c_blas/dsyr.c delete mode 100644 ext/f2c_blas/dsyr2.c delete mode 100644 ext/f2c_blas/dsyr2k.c delete mode 100644 ext/f2c_blas/dsyrk.c delete mode 100644 ext/f2c_blas/dtbmv.c delete mode 100644 ext/f2c_blas/dtbsv.c delete mode 100644 ext/f2c_blas/dtpmv.c delete mode 100644 ext/f2c_blas/dtpsv.c delete mode 100644 ext/f2c_blas/dtrmm.c delete mode 100644 ext/f2c_blas/dtrmv.c delete mode 100644 ext/f2c_blas/dtrsm.c delete mode 100644 ext/f2c_blas/dtrsv.c delete mode 100644 ext/f2c_blas/dzasum.c delete mode 100644 ext/f2c_blas/dznrm2.c delete mode 100644 ext/f2c_blas/idamax.c delete mode 100644 ext/f2c_blas/isamax.c delete mode 100644 ext/f2c_blas/lsame.c delete mode 100644 ext/f2c_blas/xerbla.c delete mode 100644 ext/f2c_lapack/blaswrap.h delete mode 100644 ext/f2c_lapack/dbdsqr.c delete mode 100644 ext/f2c_lapack/dgbcon.c delete mode 100644 ext/f2c_lapack/dgbequ.c delete mode 100644 ext/f2c_lapack/dgbrfs.c delete mode 100644 ext/f2c_lapack/dgbsv.c delete mode 100644 ext/f2c_lapack/dgbtf2.c delete mode 100644 ext/f2c_lapack/dgbtrf.c delete mode 100644 ext/f2c_lapack/dgbtrs.c delete mode 100644 ext/f2c_lapack/dgebak.c delete mode 100644 ext/f2c_lapack/dgebal.c delete mode 100644 ext/f2c_lapack/dgebd2.c delete mode 100644 ext/f2c_lapack/dgebrd.c delete mode 100644 ext/f2c_lapack/dgecon.c delete mode 100644 ext/f2c_lapack/dgeequ.c delete mode 100644 ext/f2c_lapack/dgelq2.c delete mode 100644 ext/f2c_lapack/dgelqf.c delete mode 100644 ext/f2c_lapack/dgels.c delete mode 100644 ext/f2c_lapack/dgelss.c delete mode 100644 ext/f2c_lapack/dgeqr2.c delete mode 100644 ext/f2c_lapack/dgeqrf.c delete mode 100644 ext/f2c_lapack/dgerfs.c delete mode 100644 ext/f2c_lapack/dgetf2.c delete mode 100644 ext/f2c_lapack/dgetrf.c delete mode 100644 ext/f2c_lapack/dgetri.c delete mode 100644 ext/f2c_lapack/dgetrs.c delete mode 100644 ext/f2c_lapack/dlabad.c delete mode 100644 ext/f2c_lapack/dlabrd.c delete mode 100644 ext/f2c_lapack/dlacon.c delete mode 100644 ext/f2c_lapack/dlacpy.c delete mode 100644 ext/f2c_lapack/dlamch.c delete mode 100644 ext/f2c_lapack/dlange.c delete mode 100644 ext/f2c_lapack/dlantr.c delete mode 100644 ext/f2c_lapack/dlapy2.c delete mode 100644 ext/f2c_lapack/dlarf.c delete mode 100644 ext/f2c_lapack/dlarfb.c delete mode 100644 ext/f2c_lapack/dlarfg.c delete mode 100644 ext/f2c_lapack/dlarft.c delete mode 100644 ext/f2c_lapack/dlartg.c delete mode 100644 ext/f2c_lapack/dlas2.c delete mode 100644 ext/f2c_lapack/dlascl.c delete mode 100644 ext/f2c_lapack/dlaset.c delete mode 100644 ext/f2c_lapack/dlasq1.c delete mode 100644 ext/f2c_lapack/dlasq2.c delete mode 100644 ext/f2c_lapack/dlasq3.c delete mode 100644 ext/f2c_lapack/dlasq4.c delete mode 100644 ext/f2c_lapack/dlasq5.c delete mode 100644 ext/f2c_lapack/dlasq6.c delete mode 100644 ext/f2c_lapack/dlasr.c delete mode 100644 ext/f2c_lapack/dlasrt.c delete mode 100644 ext/f2c_lapack/dlassq.c delete mode 100644 ext/f2c_lapack/dlasv2.c delete mode 100644 ext/f2c_lapack/dlaswp.c delete mode 100644 ext/f2c_lapack/dlatbs.c delete mode 100644 ext/f2c_lapack/dlatrs.c delete mode 100644 ext/f2c_lapack/dorg2r.c delete mode 100644 ext/f2c_lapack/dorgbr.c delete mode 100644 ext/f2c_lapack/dorgl2.c delete mode 100644 ext/f2c_lapack/dorglq.c delete mode 100644 ext/f2c_lapack/dorgqr.c delete mode 100644 ext/f2c_lapack/dorm2r.c delete mode 100644 ext/f2c_lapack/dormbr.c delete mode 100644 ext/f2c_lapack/dorml2.c delete mode 100644 ext/f2c_lapack/dormlq.c delete mode 100644 ext/f2c_lapack/dormqr.c delete mode 100644 ext/f2c_lapack/dpotf2.c delete mode 100644 ext/f2c_lapack/dpotrf.c delete mode 100644 ext/f2c_lapack/dpotrs.c delete mode 100644 ext/f2c_lapack/drscl.c delete mode 100644 ext/f2c_lapack/dtrcon.c delete mode 100644 ext/f2c_lapack/dtrti2.c delete mode 100644 ext/f2c_lapack/dtrtri.c delete mode 100644 ext/f2c_lapack/dtrtrs.c delete mode 100644 ext/f2c_lapack/ieeeck.c delete mode 100644 ext/f2c_lapack/ilaenv.c delete mode 100644 ext/f2c_libs/.gitignore delete mode 100644 ext/f2c_libs/abort_.c delete mode 100644 ext/f2c_libs/arithchk/arithchk.c delete mode 100644 ext/f2c_libs/backspac.c delete mode 100644 ext/f2c_libs/c_abs.c delete mode 100644 ext/f2c_libs/c_cos.c delete mode 100644 ext/f2c_libs/c_div.c delete mode 100644 ext/f2c_libs/c_exp.c delete mode 100644 ext/f2c_libs/c_log.c delete mode 100644 ext/f2c_libs/c_sin.c delete mode 100644 ext/f2c_libs/c_sqrt.c delete mode 100644 ext/f2c_libs/cabs.c delete mode 100644 ext/f2c_libs/close.c delete mode 100644 ext/f2c_libs/d_abs.c delete mode 100644 ext/f2c_libs/d_acos.c delete mode 100644 ext/f2c_libs/d_asin.c delete mode 100644 ext/f2c_libs/d_atan.c delete mode 100644 ext/f2c_libs/d_atn2.c delete mode 100644 ext/f2c_libs/d_cnjg.c delete mode 100644 ext/f2c_libs/d_cos.c delete mode 100644 ext/f2c_libs/d_cosh.c delete mode 100644 ext/f2c_libs/d_dim.c delete mode 100644 ext/f2c_libs/d_exp.c delete mode 100644 ext/f2c_libs/d_imag.c delete mode 100644 ext/f2c_libs/d_int.c delete mode 100644 ext/f2c_libs/d_lg10.c delete mode 100644 ext/f2c_libs/d_log.c delete mode 100644 ext/f2c_libs/d_mod.c delete mode 100644 ext/f2c_libs/d_nint.c delete mode 100644 ext/f2c_libs/d_prod.c delete mode 100644 ext/f2c_libs/d_sign.c delete mode 100644 ext/f2c_libs/d_sin.c delete mode 100644 ext/f2c_libs/d_sinh.c delete mode 100644 ext/f2c_libs/d_sqrt.c delete mode 100644 ext/f2c_libs/d_tan.c delete mode 100644 ext/f2c_libs/d_tanh.c delete mode 100644 ext/f2c_libs/dfe.c delete mode 100644 ext/f2c_libs/dolio.c delete mode 100644 ext/f2c_libs/dtime_.c delete mode 100644 ext/f2c_libs/due.c delete mode 100644 ext/f2c_libs/ef1asc_.c delete mode 100644 ext/f2c_libs/ef1cmc_.c delete mode 100644 ext/f2c_libs/endfile.c delete mode 100644 ext/f2c_libs/err.c delete mode 100644 ext/f2c_libs/etime_.c delete mode 100644 ext/f2c_libs/exit_.c delete mode 100644 ext/f2c_libs/f2c.h delete mode 100644 ext/f2c_libs/f2c.h0 delete mode 100644 ext/f2c_libs/f2ch.add delete mode 100644 ext/f2c_libs/f77_aloc.c delete mode 100644 ext/f2c_libs/f77vers.c delete mode 100644 ext/f2c_libs/fio.h delete mode 100644 ext/f2c_libs/fmt.c delete mode 100644 ext/f2c_libs/fmt.h delete mode 100644 ext/f2c_libs/fmtlib.c delete mode 100644 ext/f2c_libs/fp.h delete mode 100644 ext/f2c_libs/ftell_.c delete mode 100644 ext/f2c_libs/getenv_.c delete mode 100644 ext/f2c_libs/h_abs.c delete mode 100644 ext/f2c_libs/h_dim.c delete mode 100644 ext/f2c_libs/h_dnnt.c delete mode 100644 ext/f2c_libs/h_indx.c delete mode 100644 ext/f2c_libs/h_len.c delete mode 100644 ext/f2c_libs/h_mod.c delete mode 100644 ext/f2c_libs/h_nint.c delete mode 100644 ext/f2c_libs/h_sign.c delete mode 100644 ext/f2c_libs/hl_ge.c delete mode 100644 ext/f2c_libs/hl_gt.c delete mode 100644 ext/f2c_libs/hl_le.c delete mode 100644 ext/f2c_libs/hl_lt.c delete mode 100644 ext/f2c_libs/i77vers.c delete mode 100644 ext/f2c_libs/i_abs.c delete mode 100644 ext/f2c_libs/i_dim.c delete mode 100644 ext/f2c_libs/i_dnnt.c delete mode 100644 ext/f2c_libs/i_indx.c delete mode 100644 ext/f2c_libs/i_len.c delete mode 100644 ext/f2c_libs/i_mod.c delete mode 100644 ext/f2c_libs/i_nint.c delete mode 100644 ext/f2c_libs/i_sign.c delete mode 100644 ext/f2c_libs/iio.c delete mode 100644 ext/f2c_libs/ilnw.c delete mode 100644 ext/f2c_libs/inquire.c delete mode 100644 ext/f2c_libs/l_ge.c delete mode 100644 ext/f2c_libs/l_gt.c delete mode 100644 ext/f2c_libs/l_le.c delete mode 100644 ext/f2c_libs/l_lt.c delete mode 100644 ext/f2c_libs/lbitbits.c delete mode 100644 ext/f2c_libs/lbitshft.c delete mode 100644 ext/f2c_libs/lio.h delete mode 100644 ext/f2c_libs/lread.c delete mode 100644 ext/f2c_libs/lwrite.c delete mode 100644 ext/f2c_libs/open.c delete mode 100644 ext/f2c_libs/pow_ci.c delete mode 100644 ext/f2c_libs/pow_dd.c delete mode 100644 ext/f2c_libs/pow_di.c delete mode 100644 ext/f2c_libs/pow_hh.c delete mode 100644 ext/f2c_libs/pow_ii.c delete mode 100644 ext/f2c_libs/pow_ri.c delete mode 100644 ext/f2c_libs/pow_zi.c delete mode 100644 ext/f2c_libs/pow_zz.c delete mode 100644 ext/f2c_libs/r_abs.c delete mode 100644 ext/f2c_libs/r_acos.c delete mode 100644 ext/f2c_libs/r_asin.c delete mode 100644 ext/f2c_libs/r_atan.c delete mode 100644 ext/f2c_libs/r_atn2.c delete mode 100644 ext/f2c_libs/r_cnjg.c delete mode 100644 ext/f2c_libs/r_cos.c delete mode 100644 ext/f2c_libs/r_cosh.c delete mode 100644 ext/f2c_libs/r_dim.c delete mode 100644 ext/f2c_libs/r_exp.c delete mode 100644 ext/f2c_libs/r_imag.c delete mode 100644 ext/f2c_libs/r_int.c delete mode 100644 ext/f2c_libs/r_lg10.c delete mode 100644 ext/f2c_libs/r_log.c delete mode 100644 ext/f2c_libs/r_mod.c delete mode 100644 ext/f2c_libs/r_nint.c delete mode 100644 ext/f2c_libs/r_sign.c delete mode 100644 ext/f2c_libs/r_sin.c delete mode 100644 ext/f2c_libs/r_sinh.c delete mode 100644 ext/f2c_libs/r_sqrt.c delete mode 100644 ext/f2c_libs/r_tan.c delete mode 100644 ext/f2c_libs/r_tanh.c delete mode 100644 ext/f2c_libs/rawio.h delete mode 100644 ext/f2c_libs/rdfmt.c delete mode 100644 ext/f2c_libs/rewind.c delete mode 100644 ext/f2c_libs/rsfe.c delete mode 100644 ext/f2c_libs/rsli.c delete mode 100644 ext/f2c_libs/rsne.c delete mode 100644 ext/f2c_libs/s_cat.c delete mode 100644 ext/f2c_libs/s_cmp.c delete mode 100644 ext/f2c_libs/s_copy.c delete mode 100644 ext/f2c_libs/s_rnge.c delete mode 100644 ext/f2c_libs/s_stop.c delete mode 100644 ext/f2c_libs/sfe.c delete mode 100644 ext/f2c_libs/sig_die.c delete mode 100644 ext/f2c_libs/signal1.h delete mode 100644 ext/f2c_libs/signal_.c delete mode 100644 ext/f2c_libs/signbit.c delete mode 100644 ext/f2c_libs/sue.c delete mode 100644 ext/f2c_libs/sysdep1.h delete mode 100644 ext/f2c_libs/system_.c delete mode 100644 ext/f2c_libs/typesize.c delete mode 100644 ext/f2c_libs/uio.c delete mode 100644 ext/f2c_libs/uninit.c delete mode 100644 ext/f2c_libs/util.c delete mode 100644 ext/f2c_libs/wref.c delete mode 100644 ext/f2c_libs/wrtfmt.c delete mode 100644 ext/f2c_libs/wsfe.c delete mode 100644 ext/f2c_libs/wsle.c delete mode 100644 ext/f2c_libs/wsne.c delete mode 100644 ext/f2c_libs/xwsne.c delete mode 100644 ext/f2c_libs/z_abs.c delete mode 100644 ext/f2c_libs/z_cos.c delete mode 100644 ext/f2c_libs/z_div.c delete mode 100644 ext/f2c_libs/z_exp.c delete mode 100644 ext/f2c_libs/z_log.c delete mode 100644 ext/f2c_libs/z_sin.c delete mode 100644 ext/f2c_libs/z_sqrt.c delete mode 100644 ext/f2c_math/cblas.h delete mode 100644 ext/f2c_math/daux.c delete mode 100644 ext/f2c_math/ddaspk.c delete mode 100644 ext/f2c_math/dgbefa.c delete mode 100644 ext/f2c_math/dgbsl.c delete mode 100644 ext/f2c_math/dgefa.c delete mode 100644 ext/f2c_math/dgesl.c delete mode 100644 ext/f2c_math/dp1vlu.c delete mode 100644 ext/f2c_math/dpcoef.c delete mode 100644 ext/f2c_math/dpolft.c delete mode 100644 ext/f2c_math/fdump.c delete mode 100644 ext/f2c_math/j4save.c delete mode 100644 ext/f2c_math/mach.cpp delete mode 100644 ext/f2c_math/pcoef.c delete mode 100644 ext/f2c_math/polfit.c delete mode 100644 ext/f2c_math/printstring.c delete mode 100644 ext/f2c_math/pvalue.c delete mode 100644 ext/f2c_math/xercnt.c delete mode 100644 ext/f2c_math/xerhlt.c delete mode 100644 ext/f2c_math/xermsg.c delete mode 100644 ext/f2c_math/xerprn.c delete mode 100644 ext/f2c_math/xersve.c delete mode 100644 ext/f2c_math/xgetua.c delete mode 100644 ext/lapack/dbdsqr.f delete mode 100644 ext/lapack/dgbcon.f delete mode 100644 ext/lapack/dgbequ.f delete mode 100644 ext/lapack/dgbsv.f delete mode 100644 ext/lapack/dgbtf2.f delete mode 100644 ext/lapack/dgbtrf.f delete mode 100644 ext/lapack/dgbtrs.f delete mode 100644 ext/lapack/dgebd2.f delete mode 100644 ext/lapack/dgebrd.f delete mode 100644 ext/lapack/dgecon.f delete mode 100644 ext/lapack/dgeequ.f delete mode 100644 ext/lapack/dgelq2.f delete mode 100644 ext/lapack/dgelqf.f delete mode 100644 ext/lapack/dgelss.f delete mode 100644 ext/lapack/dgeqr2.f delete mode 100644 ext/lapack/dgeqrf.f delete mode 100644 ext/lapack/dgerfs.f delete mode 100644 ext/lapack/dgetf2.f delete mode 100644 ext/lapack/dgetrf.f delete mode 100644 ext/lapack/dgetri.f delete mode 100644 ext/lapack/dgetrs.f delete mode 100644 ext/lapack/dlabad.f delete mode 100644 ext/lapack/dlabrd.f delete mode 100644 ext/lapack/dlacon.f delete mode 100644 ext/lapack/dlacpy.f delete mode 100644 ext/lapack/dlamch.f delete mode 100644 ext/lapack/dlange.f delete mode 100644 ext/lapack/dlantr.f delete mode 100644 ext/lapack/dlapy2.f delete mode 100644 ext/lapack/dlarf.f delete mode 100644 ext/lapack/dlarfb.f delete mode 100644 ext/lapack/dlarfg.f delete mode 100644 ext/lapack/dlarft.f delete mode 100644 ext/lapack/dlartg.f delete mode 100644 ext/lapack/dlas2.f delete mode 100644 ext/lapack/dlascl.f delete mode 100644 ext/lapack/dlaset.f delete mode 100644 ext/lapack/dlasq1.f delete mode 100644 ext/lapack/dlasq2.f delete mode 100644 ext/lapack/dlasq3.f delete mode 100644 ext/lapack/dlasq4.f delete mode 100644 ext/lapack/dlasr.f delete mode 100644 ext/lapack/dlasrt.f delete mode 100644 ext/lapack/dlassq.f delete mode 100644 ext/lapack/dlasv2.f delete mode 100644 ext/lapack/dlaswp.f delete mode 100644 ext/lapack/dlatbs.f delete mode 100644 ext/lapack/dlatrs.f delete mode 100644 ext/lapack/dorg2r.f delete mode 100644 ext/lapack/dorgbr.f delete mode 100644 ext/lapack/dorgl2.f delete mode 100644 ext/lapack/dorglq.f delete mode 100644 ext/lapack/dorgqr.f delete mode 100644 ext/lapack/dorm2r.f delete mode 100644 ext/lapack/dormbr.f delete mode 100644 ext/lapack/dorml2.f delete mode 100644 ext/lapack/dormlq.f delete mode 100644 ext/lapack/dormqr.f delete mode 100644 ext/lapack/dpotf2.f delete mode 100644 ext/lapack/dpotrf.f delete mode 100644 ext/lapack/dpotrs.f delete mode 100644 ext/lapack/drscl.f delete mode 100644 ext/lapack/dtrcon.f delete mode 100644 ext/lapack/dtrtrs.f delete mode 100644 ext/lapack/ilaenv.f delete mode 100644 ext/lapack/lsame.f delete mode 100644 ext/math/daux.f delete mode 100644 ext/math/ddaspk.f delete mode 100644 ext/math/dgbfa.f delete mode 100644 ext/math/dgbsl.f delete mode 100644 ext/math/dgefa.f delete mode 100644 ext/math/dgesl.f delete mode 100644 ext/math/dp1vlu.f delete mode 100644 ext/math/dpcoef.f delete mode 100644 ext/math/dpolft.f delete mode 100644 ext/math/fdump.f delete mode 100644 ext/math/j4save.f delete mode 100644 ext/math/mach.cpp delete mode 100644 ext/math/pcoef.f delete mode 100644 ext/math/polfit.f delete mode 100644 ext/math/printstring.c delete mode 100644 ext/math/pvalue.f delete mode 100644 ext/math/xercnt.f delete mode 100644 ext/math/xerhlt.f delete mode 100644 ext/math/xermsg.f delete mode 100644 ext/math/xerprn.f delete mode 100644 ext/math/xersve.f delete mode 100644 ext/math/xgetua.f diff --git a/ext/blas/dasum.f b/ext/blas/dasum.f deleted file mode 100644 index 28b128a84..000000000 --- a/ext/blas/dasum.f +++ /dev/null @@ -1,43 +0,0 @@ - double precision function dasum(n,dx,incx) -c -c takes the sum of the absolute values. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dtemp - integer i,incx,m,mp1,n,nincx -c - dasum = 0.0d0 - dtemp = 0.0d0 - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - dtemp = dtemp + dabs(dx(i)) - 10 continue - dasum = dtemp - return -c -c code for increment equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,6) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dtemp + dabs(dx(i)) - 30 continue - if( n .lt. 6 ) go to 60 - 40 mp1 = m + 1 - do 50 i = mp1,n,6 - dtemp = dtemp + dabs(dx(i)) + dabs(dx(i + 1)) + dabs(dx(i + 2)) - * + dabs(dx(i + 3)) + dabs(dx(i + 4)) + dabs(dx(i + 5)) - 50 continue - 60 dasum = dtemp - return - end diff --git a/ext/blas/daxpy.f b/ext/blas/daxpy.f deleted file mode 100644 index 91daa3c64..000000000 --- a/ext/blas/daxpy.f +++ /dev/null @@ -1,48 +0,0 @@ - subroutine daxpy(n,da,dx,incx,dy,incy) -c -c constant times a vector plus a vector. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),da - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if (da .eq. 0.0d0) return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dy(iy) = dy(iy) + da*dx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,4) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dy(i) = dy(i) + da*dx(i) - 30 continue - if( n .lt. 4 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,4 - dy(i) = dy(i) + da*dx(i) - dy(i + 1) = dy(i + 1) + da*dx(i + 1) - dy(i + 2) = dy(i + 2) + da*dx(i + 2) - dy(i + 3) = dy(i + 3) + da*dx(i + 3) - 50 continue - return - end diff --git a/ext/blas/dcabs1.f b/ext/blas/dcabs1.f deleted file mode 100644 index 385ea5e1a..000000000 --- a/ext/blas/dcabs1.f +++ /dev/null @@ -1,8 +0,0 @@ - double precision function dcabs1(z) - double complex z,zz - double precision t(2) - equivalence (zz,t(1)) - zz = z - dcabs1 = dabs(t(1)) + dabs(t(2)) - return - end diff --git a/ext/blas/dcopy.f b/ext/blas/dcopy.f deleted file mode 100644 index e16892716..000000000 --- a/ext/blas/dcopy.f +++ /dev/null @@ -1,50 +0,0 @@ - subroutine dcopy(n,dx,incx,dy,incy) -c -c copies a vector, x, to a vector, y. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*) - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dy(iy) = dx(ix) - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,7) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dy(i) = dx(i) - 30 continue - if( n .lt. 7 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,7 - dy(i) = dx(i) - dy(i + 1) = dx(i + 1) - dy(i + 2) = dx(i + 2) - dy(i + 3) = dx(i + 3) - dy(i + 4) = dx(i + 4) - dy(i + 5) = dx(i + 5) - dy(i + 6) = dx(i + 6) - 50 continue - return - end diff --git a/ext/blas/ddot.f b/ext/blas/ddot.f deleted file mode 100644 index e04c7c25e..000000000 --- a/ext/blas/ddot.f +++ /dev/null @@ -1,49 +0,0 @@ - double precision function ddot(n,dx,incx,dy,incy) -c -c forms the dot product of two vectors. -c uses unrolled loops for increments equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),dtemp - integer i,incx,incy,ix,iy,m,mp1,n -c - ddot = 0.0d0 - dtemp = 0.0d0 - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments -c not equal to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = dtemp + dx(ix)*dy(iy) - ix = ix + incx - iy = iy + incy - 10 continue - ddot = dtemp - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dtemp + dx(i)*dy(i) - 30 continue - if( n .lt. 5 ) go to 60 - 40 mp1 = m + 1 - do 50 i = mp1,n,5 - dtemp = dtemp + dx(i)*dy(i) + dx(i + 1)*dy(i + 1) + - * dx(i + 2)*dy(i + 2) + dx(i + 3)*dy(i + 3) + dx(i + 4)*dy(i + 4) - 50 continue - 60 ddot = dtemp - return - end diff --git a/ext/blas/dgbmv.f b/ext/blas/dgbmv.f deleted file mode 100644 index e9c8f76fb..000000000 --- a/ext/blas/dgbmv.f +++ /dev/null @@ -1,300 +0,0 @@ - SUBROUTINE DGBMV ( TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, KL, KU, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DGBMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n band matrix, with kl sub-diagonals and ku super-diagonals. -* -* Parameters -* ========== -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* KL - INTEGER. -* On entry, KL specifies the number of sub-diagonals of the -* matrix A. KL must satisfy 0 .le. KL. -* Unchanged on exit. -* -* KU - INTEGER. -* On entry, KU specifies the number of super-diagonals of the -* matrix A. KU must satisfy 0 .le. KU. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry, the leading ( kl + ku + 1 ) by n part of the -* array A must contain the matrix of coefficients, supplied -* column by column, with the leading diagonal of the matrix in -* row ( ku + 1 ) of the array, the first super-diagonal -* starting at position 2 in row ku, the first sub-diagonal -* starting at position 1 in row ( ku + 2 ), and so on. -* Elements in the array A that do not correspond to elements -* in the band matrix (such as the top left ku by ku triangle) -* are not referenced. -* The following program segment will transfer a band matrix -* from conventional full matrix storage to band storage: -* -* DO 20, J = 1, N -* K = KU + 1 - J -* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) -* A( K + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( kl + ku + 1 ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry, the incremented array Y must contain the -* vector y. On exit, Y is overwritten by the updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, K, KUP1, KX, KY, - $ LENX, LENY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( KL.LT.0 )THEN - INFO = 4 - ELSE IF( KU.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( KL + KU + 1 ) )THEN - INFO = 8 - ELSE IF( INCX.EQ.0 )THEN - INFO = 10 - ELSE IF( INCY.EQ.0 )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF( LSAME( TRANS, 'N' ) )THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the band part of A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KUP1 = KU + 1 - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - K = KUP1 - J - DO 50, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( I ) = Y( I ) + TEMP*A( K + I, J ) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - K = KUP1 - J - DO 70, I = MAX( 1, J - KU ), MIN( M, J + KL ) - Y( IY ) = Y( IY ) + TEMP*A( K + I, J ) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - IF( J.GT.KU ) - $ KY = KY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = ZERO - K = KUP1 - J - DO 90, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( I ) - 90 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120, J = 1, N - TEMP = ZERO - IX = KX - K = KUP1 - J - DO 110, I = MAX( 1, J - KU ), MIN( M, J + KL ) - TEMP = TEMP + A( K + I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - IF( J.GT.KU ) - $ KX = KX + INCX - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGBMV . -* - END diff --git a/ext/blas/dgemm.f b/ext/blas/dgemm.f deleted file mode 100644 index baabe4c52..000000000 --- a/ext/blas/dgemm.f +++ /dev/null @@ -1,313 +0,0 @@ - SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 TRANSA, TRANSB - INTEGER M, N, K, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DGEMM performs one of the matrix-matrix operations -* -* C := alpha*op( A )*op( B ) + beta*C, -* -* where op( X ) is one of -* -* op( X ) = X or op( X ) = X', -* -* alpha and beta are scalars, and A, B and C are matrices, with op( A ) -* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. -* -* Parameters -* ========== -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n', op( A ) = A. -* -* TRANSA = 'T' or 't', op( A ) = A'. -* -* TRANSA = 'C' or 'c', op( A ) = A'. -* -* Unchanged on exit. -* -* TRANSB - CHARACTER*1. -* On entry, TRANSB specifies the form of op( B ) to be used in -* the matrix multiplication as follows: -* -* TRANSB = 'N' or 'n', op( B ) = B. -* -* TRANSB = 'T' or 't', op( B ) = B'. -* -* TRANSB = 'C' or 'c', op( B ) = B'. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix -* op( A ) and of the matrix C. M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix -* op( B ) and the number of columns of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry, K specifies the number of columns of the matrix -* op( A ) and the number of rows of the matrix op( B ). K must -* be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -* k when TRANSA = 'N' or 'n', and is m otherwise. -* Before entry with TRANSA = 'N' or 'n', the leading m by k -* part of the array A must contain the matrix A, otherwise -* the leading k by m part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANSA = 'N' or 'n' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, k ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is -* n when TRANSB = 'N' or 'n', and is k otherwise. -* Before entry with TRANSB = 'N' or 'n', the leading k by n -* part of the array B must contain the matrix B, otherwise -* the leading n by k part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANSB = 'N' or 'n' then -* LDB must be at least max( 1, k ), otherwise LDB must be at -* least max( 1, n ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -* Before entry, the leading m by n part of the array C must -* contain the matrix C, except when beta is zero, in which -* case C need not be set on entry. -* On exit, the array C is overwritten by the m by n matrix -* ( alpha*op( A )*op( B ) + beta*C ). -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL NOTA, NOTB - INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Set NOTA and NOTB as true if A and B respectively are not -* transposed and set NROWA, NCOLA and NROWB as the number of rows -* and columns of A and the number of rows of B respectively. -* - NOTA = LSAME( TRANSA, 'N' ) - NOTB = LSAME( TRANSB, 'N' ) - IF( NOTA )THEN - NROWA = M - NCOLA = K - ELSE - NROWA = K - NCOLA = M - END IF - IF( NOTB )THEN - NROWB = K - ELSE - NROWB = N - END IF -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.NOTA ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.NOTB ).AND. - $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. - $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( K .LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 8 - ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN - INFO = 10 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 13 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGEMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And if alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, M - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF( NOTB )THEN - IF( NOTA )THEN -* -* Form C := alpha*A*B + beta*C. -* - DO 90, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 50, I = 1, M - C( I, J ) = ZERO - 50 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 60, I = 1, M - C( I, J ) = BETA*C( I, J ) - 60 CONTINUE - END IF - DO 80, L = 1, K - IF( B( L, J ).NE.ZERO )THEN - TEMP = ALPHA*B( L, J ) - DO 70, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 70 CONTINUE - END IF - 80 CONTINUE - 90 CONTINUE - ELSE -* -* Form C := alpha*A'*B + beta*C -* - DO 120, J = 1, N - DO 110, I = 1, M - TEMP = ZERO - DO 100, L = 1, K - TEMP = TEMP + A( L, I )*B( L, J ) - 100 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 110 CONTINUE - 120 CONTINUE - END IF - ELSE - IF( NOTA )THEN -* -* Form C := alpha*A*B' + beta*C -* - DO 170, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 130, I = 1, M - C( I, J ) = ZERO - 130 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 140, I = 1, M - C( I, J ) = BETA*C( I, J ) - 140 CONTINUE - END IF - DO 160, L = 1, K - IF( B( J, L ).NE.ZERO )THEN - TEMP = ALPHA*B( J, L ) - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 150 CONTINUE - END IF - 160 CONTINUE - 170 CONTINUE - ELSE -* -* Form C := alpha*A'*B' + beta*C -* - DO 200, J = 1, N - DO 190, I = 1, M - TEMP = ZERO - DO 180, L = 1, K - TEMP = TEMP + A( L, I )*B( J, L ) - 180 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 190 CONTINUE - 200 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMM . -* - END diff --git a/ext/blas/dgemv.f b/ext/blas/dgemv.f deleted file mode 100644 index 8ef80b3a5..000000000 --- a/ext/blas/dgemv.f +++ /dev/null @@ -1,261 +0,0 @@ - SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, LDA, M, N - CHARACTER*1 TRANS -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DGEMV performs one of the matrix-vector operations -* -* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, -* -* where alpha and beta are scalars, x and y are vectors and A is an -* m by n matrix. -* -* Parameters -* ========== -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' y := alpha*A*x + beta*y. -* -* TRANS = 'T' or 't' y := alpha*A'*x + beta*y. -* -* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of DIMENSION at least -* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' -* and at least -* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. -* Before entry with BETA non-zero, the incremented array Y -* must contain the vector y. On exit, Y is overwritten by the -* updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 1 - ELSE IF( M.LT.0 )THEN - INFO = 2 - ELSE IF( N.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGEMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set LENX and LENY, the lengths of the vectors x and y, and set -* up the start points in X and Y. -* - IF( LSAME( TRANS, 'N' ) )THEN - LENX = N - LENY = M - ELSE - LENX = M - LENY = N - END IF - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( LENX - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( LENY - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, LENY - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, LENY - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, LENY - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, LENY - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form y := alpha*A*x + y. -* - JX = KX - IF( INCY.EQ.1 )THEN - DO 60, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - DO 50, I = 1, M - Y( I ) = Y( I ) + TEMP*A( I, J ) - 50 CONTINUE - END IF - JX = JX + INCX - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IY = KY - DO 70, I = 1, M - Y( IY ) = Y( IY ) + TEMP*A( I, J ) - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - ELSE -* -* Form y := alpha*A'*x + y. -* - JY = KY - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = ZERO - DO 90, I = 1, M - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 100 CONTINUE - ELSE - DO 120, J = 1, N - TEMP = ZERO - IX = KX - DO 110, I = 1, M - TEMP = TEMP + A( I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEMV . -* - END diff --git a/ext/blas/dger.f b/ext/blas/dger.f deleted file mode 100644 index d316000ab..000000000 --- a/ext/blas/dger.f +++ /dev/null @@ -1,157 +0,0 @@ - SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, LDA, M, N -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DGER performs the rank 1 operation -* -* A := alpha*x*y' + A, -* -* where alpha is a scalar, x is an m element vector, y is an n element -* vector and A is an m by n matrix. -* -* Parameters -* ========== -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix A. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( m - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the m -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry, the leading m by n part of the array A must -* contain the matrix of coefficients. On exit, A is -* overwritten by the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JY, KX -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( M.LT.0 )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, M ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DGER ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( INCY.GT.0 )THEN - JY = 1 - ELSE - JY = 1 - ( N - 1 )*INCY - END IF - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - DO 10, I = 1, M - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - JY = JY + INCY - 20 CONTINUE - ELSE - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( M - 1 )*INCX - END IF - DO 40, J = 1, N - IF( Y( JY ).NE.ZERO )THEN - TEMP = ALPHA*Y( JY ) - IX = KX - DO 30, I = 1, M - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JY = JY + INCY - 40 CONTINUE - END IF -* - RETURN -* -* End of DGER . -* - END diff --git a/ext/blas/dnrm2.f b/ext/blas/dnrm2.f deleted file mode 100644 index 119d0477e..000000000 --- a/ext/blas/dnrm2.f +++ /dev/null @@ -1,60 +0,0 @@ - DOUBLE PRECISION FUNCTION DNRM2 ( N, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* DNRM2 returns the euclidean norm of a vector via the function -* name, so that -* -* DNRM2 := sqrt( x'*x ) -* -* -* -* -- This version written on 25-October-1982. -* Modified on 14-October-1993 to inline the call to DLASSQ. -* Sven Hammarling, Nag Ltd. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION ABSXI, NORM, SCALE, SSQ -* .. Intrinsic Functions .. - INTRINSIC ABS, SQRT -* .. -* .. Executable Statements .. - IF( N.LT.1 .OR. INCX.LT.1 )THEN - NORM = ZERO - ELSE IF( N.EQ.1 )THEN - NORM = ABS( X( 1 ) ) - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL DLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - IF( X( IX ).NE.ZERO )THEN - ABSXI = ABS( X( IX ) ) - IF( SCALE.LT.ABSXI )THEN - SSQ = ONE + SSQ*( SCALE/ABSXI )**2 - SCALE = ABSXI - ELSE - SSQ = SSQ + ( ABSXI/SCALE )**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE * SQRT( SSQ ) - END IF -* - DNRM2 = NORM - RETURN -* -* End of DNRM2. -* - END diff --git a/ext/blas/drot.f b/ext/blas/drot.f deleted file mode 100644 index b9ea3bd91..000000000 --- a/ext/blas/drot.f +++ /dev/null @@ -1,37 +0,0 @@ - subroutine drot (n,dx,incx,dy,incy,c,s) -c -c applies a plane rotation. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),dtemp,c,s - integer i,incx,incy,ix,iy,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = c*dx(ix) + s*dy(iy) - dy(iy) = c*dy(iy) - s*dx(ix) - dx(ix) = dtemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c - 20 do 30 i = 1,n - dtemp = c*dx(i) + s*dy(i) - dy(i) = c*dy(i) - s*dx(i) - dx(i) = dtemp - 30 continue - return - end diff --git a/ext/blas/drotg.f b/ext/blas/drotg.f deleted file mode 100644 index 67838e2cb..000000000 --- a/ext/blas/drotg.f +++ /dev/null @@ -1,27 +0,0 @@ - subroutine drotg(da,db,c,s) -c -c construct givens plane rotation. -c jack dongarra, linpack, 3/11/78. -c - double precision da,db,c,s,roe,scale,r,z -c - roe = db - if( dabs(da) .gt. dabs(db) ) roe = da - scale = dabs(da) + dabs(db) - if( scale .ne. 0.0d0 ) go to 10 - c = 1.0d0 - s = 0.0d0 - r = 0.0d0 - z = 0.0d0 - go to 20 - 10 r = scale*dsqrt((da/scale)**2 + (db/scale)**2) - r = dsign(1.0d0,roe)*r - c = da/r - s = db/r - z = 1.0d0 - if( dabs(da) .gt. dabs(db) ) z = s - if( dabs(db) .ge. dabs(da) .and. c .ne. 0.0d0 ) z = 1.0d0/c - 20 da = r - db = z - return - end diff --git a/ext/blas/drotm.f b/ext/blas/drotm.f deleted file mode 100644 index 9a99eb7d1..000000000 --- a/ext/blas/drotm.f +++ /dev/null @@ -1,108 +0,0 @@ - SUBROUTINE DROTM (N,DX,INCX,DY,INCY,DPARAM) -C -C APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX -C -C (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN -C (DY**T) -C -C DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE -C LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. -C WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. -C -C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 -C -C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) -C H=( ) ( ) ( ) ( ) -C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). -C SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. -C - DOUBLE PRECISION DFLAG,DH12,DH22,DX,TWO,Z,DH11,DH21, - 1 DPARAM,DY,W,ZERO - DIMENSION DX(1),DY(1),DPARAM(5) - DATA ZERO,TWO/0.D0,2.D0/ -C - DFLAG=DPARAM(1) - IF(N .LE. 0 .OR.(DFLAG+TWO.EQ.ZERO)) GO TO 140 - IF(.NOT.(INCX.EQ.INCY.AND. INCX .GT.0)) GO TO 70 -C - NSTEPS=N*INCX - IF(DFLAG) 50,10,30 - 10 CONTINUE - DH12=DPARAM(4) - DH21=DPARAM(3) - DO 20 I=1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W+Z*DH12 - DY(I)=W*DH21+Z - 20 CONTINUE - GO TO 140 - 30 CONTINUE - DH11=DPARAM(2) - DH22=DPARAM(5) - DO 40 I=1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W*DH11+Z - DY(I)=-W+DH22*Z - 40 CONTINUE - GO TO 140 - 50 CONTINUE - DH11=DPARAM(2) - DH12=DPARAM(4) - DH21=DPARAM(3) - DH22=DPARAM(5) - DO 60 I=1,NSTEPS,INCX - W=DX(I) - Z=DY(I) - DX(I)=W*DH11+Z*DH12 - DY(I)=W*DH21+Z*DH22 - 60 CONTINUE - GO TO 140 - 70 CONTINUE - KX=1 - KY=1 - IF(INCX .LT. 0) KX=1+(1-N)*INCX - IF(INCY .LT. 0) KY=1+(1-N)*INCY -C - IF(DFLAG)120,80,100 - 80 CONTINUE - DH12=DPARAM(4) - DH21=DPARAM(3) - DO 90 I=1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W+Z*DH12 - DY(KY)=W*DH21+Z - KX=KX+INCX - KY=KY+INCY - 90 CONTINUE - GO TO 140 - 100 CONTINUE - DH11=DPARAM(2) - DH22=DPARAM(5) - DO 110 I=1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W*DH11+Z - DY(KY)=-W+DH22*Z - KX=KX+INCX - KY=KY+INCY - 110 CONTINUE - GO TO 140 - 120 CONTINUE - DH11=DPARAM(2) - DH12=DPARAM(4) - DH21=DPARAM(3) - DH22=DPARAM(5) - DO 130 I=1,N - W=DX(KX) - Z=DY(KY) - DX(KX)=W*DH11+Z*DH12 - DY(KY)=W*DH21+Z*DH22 - KX=KX+INCX - KY=KY+INCY - 130 CONTINUE - 140 CONTINUE - RETURN - END diff --git a/ext/blas/drotmg.f b/ext/blas/drotmg.f deleted file mode 100644 index 0068594c0..000000000 --- a/ext/blas/drotmg.f +++ /dev/null @@ -1,169 +0,0 @@ - SUBROUTINE DROTMG (DD1,DD2,DX1,DY1,DPARAM) -C -C CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS -C THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* -C DY2)**T. -C WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. -C -C DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 -C -C (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) -C H=( ) ( ) ( ) ( ) -C (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). -C LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 -C RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE -C VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) -C -C THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE -C INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE -C OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. -C - DOUBLE PRECISION GAM,ONE,RGAMSQ,DD2,DH11,DH21,DPARAM,DP2, - 1 DQ2,DU,DY1,ZERO,GAMSQ,DD1,DFLAG,DH12,DH22,DP1,DQ1, - 2 DTEMP,DX1,TWO - DIMENSION DPARAM(5) -C - DATA ZERO,ONE,TWO /0.D0,1.D0,2.D0/ - DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/ - IF(.NOT. DD1 .LT. ZERO) GO TO 10 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 10 CONTINUE -C CASE-DD1-NONNEGATIVE - DP2=DD2*DY1 - IF(.NOT. DP2 .EQ. ZERO) GO TO 20 - DFLAG=-TWO - GO TO 260 -C REGULAR-CASE.. - 20 CONTINUE - DP1=DD1*DX1 - DQ2=DP2*DY1 - DQ1=DP1*DX1 -C - IF(.NOT. DABS(DQ1) .GT. DABS(DQ2)) GO TO 40 - DH21=-DY1/DX1 - DH12=DP2/DP1 -C - DU=ONE-DH12*DH21 -C - IF(.NOT. DU .LE. ZERO) GO TO 30 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 30 CONTINUE - DFLAG=ZERO - DD1=DD1/DU - DD2=DD2/DU - DX1=DX1*DU -C GO SCALE-CHECK.. - GO TO 100 - 40 CONTINUE - IF(.NOT. DQ2 .LT. ZERO) GO TO 50 -C GO ZERO-H-D-AND-DX1.. - GO TO 60 - 50 CONTINUE - DFLAG=ONE - DH11=DP1/DP2 - DH22=DX1/DY1 - DU=ONE+DH11*DH22 - DTEMP=DD2/DU - DD2=DD1/DU - DD1=DTEMP - DX1=DY1*DU -C GO SCALE-CHECK - GO TO 100 -C PROCEDURE..ZERO-H-D-AND-DX1.. - 60 CONTINUE - DFLAG=-ONE - DH11=ZERO - DH12=ZERO - DH21=ZERO - DH22=ZERO -C - DD1=ZERO - DD2=ZERO - DX1=ZERO -C RETURN.. - GO TO 220 -C PROCEDURE..FIX-H.. - 70 CONTINUE - IF(.NOT. DFLAG .GE. ZERO) GO TO 90 -C - IF(.NOT. DFLAG .EQ. ZERO) GO TO 80 - DH11=ONE - DH22=ONE - DFLAG=-ONE - GO TO 90 - 80 CONTINUE - DH21=-ONE - DH12=ONE - DFLAG=-ONE - 90 CONTINUE - GO TO IGO,(120,150,180,210) -C PROCEDURE..SCALE-CHECK - 100 CONTINUE - 110 CONTINUE - IF(.NOT. DD1 .LE. RGAMSQ) GO TO 130 - IF(DD1 .EQ. ZERO) GO TO 160 - ASSIGN 120 TO IGO -C FIX-H.. - GO TO 70 - 120 CONTINUE - DD1=DD1*GAM**2 - DX1=DX1/GAM - DH11=DH11/GAM - DH12=DH12/GAM - GO TO 110 - 130 CONTINUE - 140 CONTINUE - IF(.NOT. DD1 .GE. GAMSQ) GO TO 160 - ASSIGN 150 TO IGO -C FIX-H.. - GO TO 70 - 150 CONTINUE - DD1=DD1/GAM**2 - DX1=DX1*GAM - DH11=DH11*GAM - DH12=DH12*GAM - GO TO 140 - 160 CONTINUE - 170 CONTINUE - IF(.NOT. DABS(DD2) .LE. RGAMSQ) GO TO 190 - IF(DD2 .EQ. ZERO) GO TO 220 - ASSIGN 180 TO IGO -C FIX-H.. - GO TO 70 - 180 CONTINUE - DD2=DD2*GAM**2 - DH21=DH21/GAM - DH22=DH22/GAM - GO TO 170 - 190 CONTINUE - 200 CONTINUE - IF(.NOT. DABS(DD2) .GE. GAMSQ) GO TO 220 - ASSIGN 210 TO IGO -C FIX-H.. - GO TO 70 - 210 CONTINUE - DD2=DD2/GAM**2 - DH21=DH21*GAM - DH22=DH22*GAM - GO TO 200 - 220 CONTINUE - IF(DFLAG)250,230,240 - 230 CONTINUE - DPARAM(3)=DH21 - DPARAM(4)=DH12 - GO TO 260 - 240 CONTINUE - DPARAM(2)=DH11 - DPARAM(5)=DH22 - GO TO 260 - 250 CONTINUE - DPARAM(2)=DH11 - DPARAM(3)=DH21 - DPARAM(4)=DH12 - DPARAM(5)=DH22 - 260 CONTINUE - DPARAM(1)=DFLAG - RETURN - END diff --git a/ext/blas/dsbmv.f b/ext/blas/dsbmv.f deleted file mode 100644 index 272042af6..000000000 --- a/ext/blas/dsbmv.f +++ /dev/null @@ -1,303 +0,0 @@ - SUBROUTINE DSBMV ( UPLO, N, K, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, K, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSBMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric band matrix, with k super-diagonals. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the band matrix A is being supplied as -* follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* being supplied. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* being supplied. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry, K specifies the number of super-diagonals of the -* matrix A. K must satisfy 0 .le. K. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the symmetric matrix, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer the upper -* triangular part of a symmetric band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the symmetric matrix, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer the lower -* triangular part of a symmetric band matrix from conventional -* full matrix storage to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the -* vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of DIMENSION at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the -* vector y. On exit, Y is overwritten by the updated vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KPLUS1, KX, KY, L -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( K.LT.0 )THEN - INFO = 3 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - ELSE IF( INCY.EQ.0 )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array A -* are accessed sequentially with one pass through A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when upper triangle of A is stored. -* - KPLUS1 = K + 1 - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - L = KPLUS1 - J - DO 50, I = MAX( 1, J - K ), J - 1 - Y( I ) = Y( I ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - L = KPLUS1 - J - DO 70, I = MAX( 1, J - K ), J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*A( KPLUS1, J ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - IF( J.GT.K )THEN - KX = KX + INCX - KY = KY + INCY - END IF - 80 CONTINUE - END IF - ELSE -* -* Form y when lower triangle of A is stored. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*A( 1, J ) - L = 1 - J - DO 90, I = J + 1, MIN( N, J + K ) - Y( I ) = Y( I ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*A( 1, J ) - L = 1 - J - IX = JX - IY = JY - DO 110, I = J + 1, MIN( N, J + K ) - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( L + I, J ) - TEMP2 = TEMP2 + A( L + I, J )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSBMV . -* - END diff --git a/ext/blas/dscal.f b/ext/blas/dscal.f deleted file mode 100644 index e1467faf2..000000000 --- a/ext/blas/dscal.f +++ /dev/null @@ -1,43 +0,0 @@ - subroutine dscal(n,da,dx,incx) -c -c scales a vector by a constant. -c uses unrolled loops for increment equal to one. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision da,dx(*) - integer i,incx,m,mp1,n,nincx -c - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - nincx = n*incx - do 10 i = 1,nincx,incx - dx(i) = da*dx(i) - 10 continue - return -c -c code for increment equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,5) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dx(i) = da*dx(i) - 30 continue - if( n .lt. 5 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,5 - dx(i) = da*dx(i) - dx(i + 1) = da*dx(i + 1) - dx(i + 2) = da*dx(i + 2) - dx(i + 3) = da*dx(i + 3) - dx(i + 4) = da*dx(i + 4) - 50 continue - return - end diff --git a/ext/blas/dsdot.f b/ext/blas/dsdot.f deleted file mode 100644 index 85adb68d6..000000000 --- a/ext/blas/dsdot.f +++ /dev/null @@ -1,74 +0,0 @@ -*DECK DSDOT - DOUBLE PRECISION FUNCTION DSDOT (N, SX, INCX, SY, INCY) -C***BEGIN PROLOGUE DSDOT -C***PURPOSE Compute the inner product of two vectors with extended -C precision accumulation and result. -C***LIBRARY SLATEC (BLAS) -C***CATEGORY D1A4 -C***TYPE DOUBLE PRECISION (DSDOT-D, DCDOT-C) -C***KEYWORDS BLAS, COMPLEX VECTORS, DOT PRODUCT, INNER PRODUCT, -C LINEAR ALGEBRA, VECTOR -C***AUTHOR Lawson, C. L., (JPL) -C Hanson, R. J., (SNLA) -C Kincaid, D. R., (U. of Texas) -C Krogh, F. T., (JPL) -C***DESCRIPTION -C -C B L A S Subprogram -C Description of Parameters -C -C --Input-- -C N number of elements in input vector(s) -C SX single precision vector with N elements -C INCX storage spacing between elements of SX -C SY single precision vector with N elements -C INCY storage spacing between elements of SY -C -C --Output-- -C DSDOT double precision dot product (zero if N.LE.0) -C -C Returns D.P. dot product accumulated in D.P., for S.P. SX and SY -C DSDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY), -C where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is -C defined in a similar way using INCY. -C -C***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. -C Krogh, Basic linear algebra subprograms for Fortran -C usage, Algorithm No. 539, Transactions on Mathematical -C Software 5, 3 (September 1979), pp. 308-323. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 791001 DATE WRITTEN -C 890831 Modified array declarations. (WRB) -C 890831 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920310 Corrected definition of LX in DESCRIPTION. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DSDOT - REAL SX(*),SY(*) -C***FIRST EXECUTABLE STATEMENT DSDOT - DSDOT = 0.0D0 - IF (N .LE. 0) RETURN - IF (INCX.EQ.INCY .AND. INCX.GT.0) GO TO 20 -C -C Code for unequal or nonpositive increments. -C - KX = 1 - KY = 1 - IF (INCX .LT. 0) KX = 1+(1-N)*INCX - IF (INCY .LT. 0) KY = 1+(1-N)*INCY - DO 10 I = 1,N - DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY)) - KX = KX + INCX - KY = KY + INCY - 10 CONTINUE - RETURN -C -C Code for equal, positive, non-unit increments. -C - 20 NS = N*INCX - DO 30 I = 1,NS,INCX - DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I)) - 30 CONTINUE - RETURN - END diff --git a/ext/blas/dspmv.f b/ext/blas/dspmv.f deleted file mode 100644 index 3ace7bf26..000000000 --- a/ext/blas/dspmv.f +++ /dev/null @@ -1,262 +0,0 @@ - SUBROUTINE DSPMV ( UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSPMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* AP - DOUBLE PRECISION array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 6 - ELSE IF( INCY.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSPMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when AP contains the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - K = KK - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( I ) - K = K + 1 - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 - KK = KK + J - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, K = KK, KK + J - 2 - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*AP( KK + J - 1 ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 80 CONTINUE - END IF - ELSE -* -* Form y when AP contains the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*AP( KK ) - K = KK + 1 - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( I ) - K = K + 1 - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - KK = KK + ( N - J + 1 ) - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*AP( KK ) - IX = JX - IY = JY - DO 110, K = KK + 1, KK + N - J - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*AP( K ) - TEMP2 = TEMP2 + AP( K )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - KK = KK + ( N - J + 1 ) - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSPMV . -* - END diff --git a/ext/blas/dspr.f b/ext/blas/dspr.f deleted file mode 100644 index 3da6889c9..000000000 --- a/ext/blas/dspr.f +++ /dev/null @@ -1,198 +0,0 @@ - SUBROUTINE DSPR ( UPLO, N, ALPHA, X, INCX, AP ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DSPR performs the symmetric rank 1 operation -* -* A := alpha*x*x' + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n symmetric matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* AP - DOUBLE PRECISION array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSPR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - K = KK - DO 10, I = 1, J - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 10 CONTINUE - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = KX - DO 30, K = KK, KK + J - 1 - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - K = KK - DO 50, I = J, N - AP( K ) = AP( K ) + X( I )*TEMP - K = K + 1 - 50 CONTINUE - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = JX - DO 70, K = KK, KK + N - J - AP( K ) = AP( K ) + X( IX )*TEMP - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSPR . -* - END diff --git a/ext/blas/dspr2.f b/ext/blas/dspr2.f deleted file mode 100644 index 1cfce21b0..000000000 --- a/ext/blas/dspr2.f +++ /dev/null @@ -1,229 +0,0 @@ - SUBROUTINE DSPR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, AP ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSPR2 performs the symmetric rank 2 operation -* -* A := alpha*x*y' + alpha*y*x' + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an -* n by n symmetric matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the matrix A is supplied in the packed -* array AP as follows: -* -* UPLO = 'U' or 'u' The upper triangular part of A is -* supplied in AP. -* -* UPLO = 'L' or 'l' The lower triangular part of A is -* supplied in AP. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* AP - DOUBLE PRECISION array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) -* and a( 2, 2 ) respectively, and so on. On exit, the array -* AP is overwritten by the upper triangular part of the -* updated matrix. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular part of the symmetric matrix -* packed sequentially, column by column, so that AP( 1 ) -* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) -* and a( 3, 1 ) respectively, and so on. On exit, the array -* AP is overwritten by the lower triangular part of the -* updated matrix. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, K, KK, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSPR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of the array AP -* are accessed sequentially with one pass through AP. -* - KK = 1 - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when upper triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - K = KK - DO 10, I = 1, J - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 10 CONTINUE - END IF - KK = KK + J - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = KX - IY = KY - DO 30, K = KK, KK + J - 1 - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + J - 40 CONTINUE - END IF - ELSE -* -* Form A when lower triangle is stored in AP. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - K = KK - DO 50, I = J, N - AP( K ) = AP( K ) + X( I )*TEMP1 + Y( I )*TEMP2 - K = K + 1 - 50 CONTINUE - END IF - KK = KK + N - J + 1 - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = JX - IY = JY - DO 70, K = KK, KK + N - J - AP( K ) = AP( K ) + X( IX )*TEMP1 + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - KK = KK + N - J + 1 - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSPR2 . -* - END diff --git a/ext/blas/dswap.f b/ext/blas/dswap.f deleted file mode 100644 index 7f7d1fbba..000000000 --- a/ext/blas/dswap.f +++ /dev/null @@ -1,56 +0,0 @@ - subroutine dswap (n,dx,incx,dy,incy) -c -c interchanges two vectors. -c uses unrolled loops for increments equal one. -c jack dongarra, linpack, 3/11/78. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dy(*),dtemp - integer i,incx,incy,ix,iy,m,mp1,n -c - if(n.le.0)return - if(incx.eq.1.and.incy.eq.1)go to 20 -c -c code for unequal increments or equal increments not equal -c to 1 -c - ix = 1 - iy = 1 - if(incx.lt.0)ix = (-n+1)*incx + 1 - if(incy.lt.0)iy = (-n+1)*incy + 1 - do 10 i = 1,n - dtemp = dx(ix) - dx(ix) = dy(iy) - dy(iy) = dtemp - ix = ix + incx - iy = iy + incy - 10 continue - return -c -c code for both increments equal to 1 -c -c -c clean-up loop -c - 20 m = mod(n,3) - if( m .eq. 0 ) go to 40 - do 30 i = 1,m - dtemp = dx(i) - dx(i) = dy(i) - dy(i) = dtemp - 30 continue - if( n .lt. 3 ) return - 40 mp1 = m + 1 - do 50 i = mp1,n,3 - dtemp = dx(i) - dx(i) = dy(i) - dy(i) = dtemp - dtemp = dx(i + 1) - dx(i + 1) = dy(i + 1) - dy(i + 1) = dtemp - dtemp = dx(i + 2) - dx(i + 2) = dy(i + 2) - dy(i + 2) = dtemp - 50 continue - return - end diff --git a/ext/blas/dsymm.f b/ext/blas/dsymm.f deleted file mode 100644 index 0f2514170..000000000 --- a/ext/blas/dsymm.f +++ /dev/null @@ -1,294 +0,0 @@ - SUBROUTINE DSYMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO - INTEGER M, N, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DSYMM performs one of the matrix-matrix operations -* -* C := alpha*A*B + beta*C, -* -* or -* -* C := alpha*B*A + beta*C, -* -* where alpha and beta are scalars, A is a symmetric matrix and B and -* C are m by n matrices. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether the symmetric matrix A -* appears on the left or right in the operation as follows: -* -* SIDE = 'L' or 'l' C := alpha*A*B + beta*C, -* -* SIDE = 'R' or 'r' C := alpha*B*A + beta*C, -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the symmetric matrix A is to be -* referenced as follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of the -* symmetric matrix is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of the -* symmetric matrix is to be referenced. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of the matrix C. -* M must be at least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of the matrix C. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -* m when SIDE = 'L' or 'l' and is n otherwise. -* Before entry with SIDE = 'L' or 'l', the m by m part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading m by m upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading m by m lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Before entry with SIDE = 'R' or 'r', the n by n part of -* the array A must contain the symmetric matrix, such that -* when UPLO = 'U' or 'u', the leading n by n upper triangular -* part of the array A must contain the upper triangular part -* of the symmetric matrix and the strictly lower triangular -* part of A is not referenced, and when UPLO = 'L' or 'l', -* the leading n by n lower triangular part of the array A -* must contain the lower triangular part of the symmetric -* matrix and the strictly upper triangular part of A is not -* referenced. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), otherwise LDA must be at -* least max( 1, n ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then C need not be set on input. -* Unchanged on exit. -* -* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -* Before entry, the leading m by n part of the array C must -* contain the matrix C, except when beta is zero, in which -* case C need not be set on entry. -* On exit, the array C is overwritten by the m by n updated -* matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP1, TEMP2 -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Set NROWA as the number of rows of A. -* - IF( LSAME( SIDE, 'L' ) )THEN - NROWA = M - ELSE - NROWA = N - END IF - UPPER = LSAME( UPLO, 'U' ) -* -* Test the input parameters. -* - INFO = 0 - IF( ( .NOT.LSAME( SIDE, 'L' ) ).AND. - $ ( .NOT.LSAME( SIDE, 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO, 'L' ) ) )THEN - INFO = 2 - ELSE IF( M .LT.0 )THEN - INFO = 3 - ELSE IF( N .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, M ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. - $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, M - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( SIDE, 'L' ) )THEN -* -* Form C := alpha*A*B + beta*C. -* - IF( UPPER )THEN - DO 70, J = 1, N - DO 60, I = 1, M - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 50, K = 1, I - 1 - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 50 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 60 CONTINUE - 70 CONTINUE - ELSE - DO 100, J = 1, N - DO 90, I = M, 1, -1 - TEMP1 = ALPHA*B( I, J ) - TEMP2 = ZERO - DO 80, K = I + 1, M - C( K, J ) = C( K, J ) + TEMP1 *A( K, I ) - TEMP2 = TEMP2 + B( K, J )*A( K, I ) - 80 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = TEMP1*A( I, I ) + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ TEMP1*A( I, I ) + ALPHA*TEMP2 - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form C := alpha*B*A + beta*C. -* - DO 170, J = 1, N - TEMP1 = ALPHA*A( J, J ) - IF( BETA.EQ.ZERO )THEN - DO 110, I = 1, M - C( I, J ) = TEMP1*B( I, J ) - 110 CONTINUE - ELSE - DO 120, I = 1, M - C( I, J ) = BETA*C( I, J ) + TEMP1*B( I, J ) - 120 CONTINUE - END IF - DO 140, K = 1, J - 1 - IF( UPPER )THEN - TEMP1 = ALPHA*A( K, J ) - ELSE - TEMP1 = ALPHA*A( J, K ) - END IF - DO 130, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 130 CONTINUE - 140 CONTINUE - DO 160, K = J + 1, N - IF( UPPER )THEN - TEMP1 = ALPHA*A( J, K ) - ELSE - TEMP1 = ALPHA*A( K, J ) - END IF - DO 150, I = 1, M - C( I, J ) = C( I, J ) + TEMP1*B( I, K ) - 150 CONTINUE - 160 CONTINUE - 170 CONTINUE - END IF -* - RETURN -* -* End of DSYMM . -* - END diff --git a/ext/blas/dsymv.f b/ext/blas/dsymv.f deleted file mode 100644 index 7592d156b..000000000 --- a/ext/blas/dsymv.f +++ /dev/null @@ -1,262 +0,0 @@ - SUBROUTINE DSYMV ( UPLO, N, ALPHA, A, LDA, X, INCX, - $ BETA, Y, INCY ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA, BETA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSYMV performs the matrix-vector operation -* -* y := alpha*A*x + beta*y, -* -* where alpha and beta are scalars, x and y are n element vectors and -* A is an n by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. When BETA is -* supplied as zero then Y need not be set on input. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. On exit, Y is overwritten by the updated -* vector y. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 5 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - ELSE IF( INCY.EQ.0 )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* Set up the start points in X and Y. -* - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* -* First form y := beta*y. -* - IF( BETA.NE.ONE )THEN - IF( INCY.EQ.1 )THEN - IF( BETA.EQ.ZERO )THEN - DO 10, I = 1, N - Y( I ) = ZERO - 10 CONTINUE - ELSE - DO 20, I = 1, N - Y( I ) = BETA*Y( I ) - 20 CONTINUE - END IF - ELSE - IY = KY - IF( BETA.EQ.ZERO )THEN - DO 30, I = 1, N - Y( IY ) = ZERO - IY = IY + INCY - 30 CONTINUE - ELSE - DO 40, I = 1, N - Y( IY ) = BETA*Y( IY ) - IY = IY + INCY - 40 CONTINUE - END IF - END IF - END IF - IF( ALPHA.EQ.ZERO ) - $ RETURN - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form y when A is stored in upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - DO 50, I = 1, J - 1 - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 50 CONTINUE - Y( J ) = Y( J ) + TEMP1*A( J, J ) + ALPHA*TEMP2 - 60 CONTINUE - ELSE - JX = KX - JY = KY - DO 80, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - IX = KX - IY = KY - DO 70, I = 1, J - 1 - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - Y( JY ) = Y( JY ) + TEMP1*A( J, J ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - ELSE -* -* Form y when A is stored in lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 100, J = 1, N - TEMP1 = ALPHA*X( J ) - TEMP2 = ZERO - Y( J ) = Y( J ) + TEMP1*A( J, J ) - DO 90, I = J + 1, N - Y( I ) = Y( I ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( I ) - 90 CONTINUE - Y( J ) = Y( J ) + ALPHA*TEMP2 - 100 CONTINUE - ELSE - JX = KX - JY = KY - DO 120, J = 1, N - TEMP1 = ALPHA*X( JX ) - TEMP2 = ZERO - Y( JY ) = Y( JY ) + TEMP1*A( J, J ) - IX = JX - IY = JY - DO 110, I = J + 1, N - IX = IX + INCX - IY = IY + INCY - Y( IY ) = Y( IY ) + TEMP1*A( I, J ) - TEMP2 = TEMP2 + A( I, J )*X( IX ) - 110 CONTINUE - Y( JY ) = Y( JY ) + ALPHA*TEMP2 - JX = JX + INCX - JY = JY + INCY - 120 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYMV . -* - END diff --git a/ext/blas/dsyr.f b/ext/blas/dsyr.f deleted file mode 100644 index 873771967..000000000 --- a/ext/blas/dsyr.f +++ /dev/null @@ -1,197 +0,0 @@ - SUBROUTINE DSYR ( UPLO, N, ALPHA, X, INCX, A, LDA ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DSYR performs the symmetric rank 1 operation -* -* A := alpha*x*x' + A, -* -* where alpha is a real scalar, x is an n element vector and A is an -* n by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KX -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYR ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set the start point in X if the increment is not unity. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in upper triangle. -* - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - DO 10, I = 1, J - A( I, J ) = A( I, J ) + X( I )*TEMP - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = KX - DO 30, I = 1, J - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 30 CONTINUE - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in lower triangle. -* - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = ALPHA*X( J ) - DO 50, I = J, N - A( I, J ) = A( I, J ) + X( I )*TEMP - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = ALPHA*X( JX ) - IX = JX - DO 70, I = J, N - A( I, J ) = A( I, J ) + X( IX )*TEMP - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR . -* - END diff --git a/ext/blas/dsyr2.f b/ext/blas/dsyr2.f deleted file mode 100644 index 918ad8a7d..000000000 --- a/ext/blas/dsyr2.f +++ /dev/null @@ -1,230 +0,0 @@ - SUBROUTINE DSYR2 ( UPLO, N, ALPHA, X, INCX, Y, INCY, A, LDA ) -* .. Scalar Arguments .. - DOUBLE PRECISION ALPHA - INTEGER INCX, INCY, LDA, N - CHARACTER*1 UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) -* .. -* -* Purpose -* ======= -* -* DSYR2 performs the symmetric rank 2 operation -* -* A := alpha*x*y' + alpha*y*x' + A, -* -* where alpha is a scalar, x and y are n element vectors and A is an n -* by n symmetric matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array A is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of A -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of A -* is to be referenced. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. -* Unchanged on exit. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* Y - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCY ) ). -* Before entry, the incremented array Y must contain the n -* element vector y. -* Unchanged on exit. -* -* INCY - INTEGER. -* On entry, INCY specifies the increment for the elements of -* Y. INCY must not be zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of A is not referenced. On exit, the -* upper triangular part of the array A is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of A is not referenced. On exit, the -* lower triangular part of the array A is overwritten by the -* lower triangular part of the updated matrix. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP1, TEMP2 - INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO, 'U' ).AND. - $ .NOT.LSAME( UPLO, 'L' ) )THEN - INFO = 1 - ELSE IF( N.LT.0 )THEN - INFO = 2 - ELSE IF( INCX.EQ.0 )THEN - INFO = 5 - ELSE IF( INCY.EQ.0 )THEN - INFO = 7 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYR2 ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) - $ RETURN -* -* Set up the start points in X and Y if the increments are not both -* unity. -* - IF( ( INCX.NE.1 ).OR.( INCY.NE.1 ) )THEN - IF( INCX.GT.0 )THEN - KX = 1 - ELSE - KX = 1 - ( N - 1 )*INCX - END IF - IF( INCY.GT.0 )THEN - KY = 1 - ELSE - KY = 1 - ( N - 1 )*INCY - END IF - JX = KX - JY = KY - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through the triangular part -* of A. -* - IF( LSAME( UPLO, 'U' ) )THEN -* -* Form A when A is stored in the upper triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 20, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - DO 10, I = 1, J - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - DO 40, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = KX - IY = KY - DO 30, I = 1, J - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 30 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 40 CONTINUE - END IF - ELSE -* -* Form A when A is stored in the lower triangle. -* - IF( ( INCX.EQ.1 ).AND.( INCY.EQ.1 ) )THEN - DO 60, J = 1, N - IF( ( X( J ).NE.ZERO ).OR.( Y( J ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( J ) - TEMP2 = ALPHA*X( J ) - DO 50, I = J, N - A( I, J ) = A( I, J ) + X( I )*TEMP1 + Y( I )*TEMP2 - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - DO 80, J = 1, N - IF( ( X( JX ).NE.ZERO ).OR.( Y( JY ).NE.ZERO ) )THEN - TEMP1 = ALPHA*Y( JY ) - TEMP2 = ALPHA*X( JX ) - IX = JX - IY = JY - DO 70, I = J, N - A( I, J ) = A( I, J ) + X( IX )*TEMP1 - $ + Y( IY )*TEMP2 - IX = IX + INCX - IY = IY + INCY - 70 CONTINUE - END IF - JX = JX + INCX - JY = JY + INCY - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR2 . -* - END diff --git a/ext/blas/dsyr2k.f b/ext/blas/dsyr2k.f deleted file mode 100644 index ac7d97de6..000000000 --- a/ext/blas/dsyr2k.f +++ /dev/null @@ -1,327 +0,0 @@ - SUBROUTINE DSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDB, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DSYR2K performs one of the symmetric rank 2k operations -* -* C := alpha*A*B' + alpha*B*A' + beta*C, -* -* or -* -* C := alpha*A'*B + alpha*B'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A and B are n by k matrices in the first case and k by n -* matrices in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + -* beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + -* beta*C. -* -* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + -* beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrices A and B, and on entry with -* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -* of rows of the matrices A and B. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array B must contain the matrix B, otherwise -* the leading k by n part of the array B must contain the -* matrix B. -* Unchanged on exit. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDB must be at least max( 1, n ), otherwise LDB must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - DOUBLE PRECISION TEMP1, TEMP2 -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 12 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYR2K', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*B' + alpha*B*A' + C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + - $ A( I, L )*TEMP1 + B( I, L )*TEMP2 - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( ( A( J, L ).NE.ZERO ).OR. - $ ( B( J, L ).NE.ZERO ) )THEN - TEMP1 = ALPHA*B( J, L ) - TEMP2 = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + - $ A( I, L )*TEMP1 + B( I, L )*TEMP2 - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*B + alpha*B'*A + C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP1 = ZERO - TEMP2 = ZERO - DO 190, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP1 = ZERO - TEMP2 = ZERO - DO 220, L = 1, K - TEMP1 = TEMP1 + A( L, I )*B( L, J ) - TEMP2 = TEMP2 + B( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP1 + ALPHA*TEMP2 - ELSE - C( I, J ) = BETA *C( I, J ) + - $ ALPHA*TEMP1 + ALPHA*TEMP2 - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYR2K. -* - END diff --git a/ext/blas/dsyrk.f b/ext/blas/dsyrk.f deleted file mode 100644 index b618b2968..000000000 --- a/ext/blas/dsyrk.f +++ /dev/null @@ -1,294 +0,0 @@ - SUBROUTINE DSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA, - $ BETA, C, LDC ) -* .. Scalar Arguments .. - CHARACTER*1 UPLO, TRANS - INTEGER N, K, LDA, LDC - DOUBLE PRECISION ALPHA, BETA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ) -* .. -* -* Purpose -* ======= -* -* DSYRK performs one of the symmetric rank k operations -* -* C := alpha*A*A' + beta*C, -* -* or -* -* C := alpha*A'*A + beta*C, -* -* where alpha and beta are scalars, C is an n by n symmetric matrix -* and A is an n by k matrix in the first case and a k by n matrix -* in the second case. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the upper or lower -* triangular part of the array C is to be referenced as -* follows: -* -* UPLO = 'U' or 'u' Only the upper triangular part of C -* is to be referenced. -* -* UPLO = 'L' or 'l' Only the lower triangular part of C -* is to be referenced. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. -* -* TRANS = 'T' or 't' C := alpha*A'*A + beta*C. -* -* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix C. N must be -* at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with TRANS = 'N' or 'n', K specifies the number -* of columns of the matrix A, and on entry with -* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number -* of rows of the matrix A. K must be at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is -* k when TRANS = 'N' or 'n', and is n otherwise. -* Before entry with TRANS = 'N' or 'n', the leading n by k -* part of the array A must contain the matrix A, otherwise -* the leading k by n part of the array A must contain the -* matrix A. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When TRANS = 'N' or 'n' -* then LDA must be at least max( 1, n ), otherwise LDA must -* be at least max( 1, k ). -* Unchanged on exit. -* -* BETA - DOUBLE PRECISION. -* On entry, BETA specifies the scalar beta. -* Unchanged on exit. -* -* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array C must contain the upper -* triangular part of the symmetric matrix and the strictly -* lower triangular part of C is not referenced. On exit, the -* upper triangular part of the array C is overwritten by the -* upper triangular part of the updated matrix. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array C must contain the lower -* triangular part of the symmetric matrix and the strictly -* upper triangular part of C is not referenced. On exit, the -* lower triangular part of the array C is overwritten by the -* lower triangular part of the updated matrix. -* -* LDC - INTEGER. -* On entry, LDC specifies the first dimension of C as declared -* in the calling (sub) program. LDC must be at least -* max( 1, n ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL UPPER - INTEGER I, INFO, J, L, NROWA - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - IF( LSAME( TRANS, 'N' ) )THEN - NROWA = N - ELSE - NROWA = K - END IF - UPPER = LSAME( UPLO, 'U' ) -* - INFO = 0 - IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.LSAME( TRANS, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN - INFO = 2 - ELSE IF( N .LT.0 )THEN - INFO = 3 - ELSE IF( K .LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 7 - ELSE IF( LDC.LT.MAX( 1, N ) )THEN - INFO = 10 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DSYRK ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( ( N.EQ.0 ).OR. - $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - IF( UPPER )THEN - IF( BETA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, J - C( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40, J = 1, N - DO 30, I = 1, J - C( I, J ) = BETA*C( I, J ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - IF( BETA.EQ.ZERO )THEN - DO 60, J = 1, N - DO 50, I = J, N - C( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80, J = 1, N - DO 70, I = J, N - C( I, J ) = BETA*C( I, J ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - RETURN - END IF -* -* Start the operations. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form C := alpha*A*A' + beta*C. -* - IF( UPPER )THEN - DO 130, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 90, I = 1, J - C( I, J ) = ZERO - 90 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 100, I = 1, J - C( I, J ) = BETA*C( I, J ) - 100 CONTINUE - END IF - DO 120, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 110, I = 1, J - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 110 CONTINUE - END IF - 120 CONTINUE - 130 CONTINUE - ELSE - DO 180, J = 1, N - IF( BETA.EQ.ZERO )THEN - DO 140, I = J, N - C( I, J ) = ZERO - 140 CONTINUE - ELSE IF( BETA.NE.ONE )THEN - DO 150, I = J, N - C( I, J ) = BETA*C( I, J ) - 150 CONTINUE - END IF - DO 170, L = 1, K - IF( A( J, L ).NE.ZERO )THEN - TEMP = ALPHA*A( J, L ) - DO 160, I = J, N - C( I, J ) = C( I, J ) + TEMP*A( I, L ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - END IF - ELSE -* -* Form C := alpha*A'*A + beta*C. -* - IF( UPPER )THEN - DO 210, J = 1, N - DO 200, I = 1, J - TEMP = ZERO - DO 190, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 190 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 200 CONTINUE - 210 CONTINUE - ELSE - DO 240, J = 1, N - DO 230, I = J, N - TEMP = ZERO - DO 220, L = 1, K - TEMP = TEMP + A( L, I )*A( L, J ) - 220 CONTINUE - IF( BETA.EQ.ZERO )THEN - C( I, J ) = ALPHA*TEMP - ELSE - C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) - END IF - 230 CONTINUE - 240 CONTINUE - END IF - END IF -* - RETURN -* -* End of DSYRK . -* - END diff --git a/ext/blas/dtbmv.f b/ext/blas/dtbmv.f deleted file mode 100644 index 1363db79c..000000000 --- a/ext/blas/dtbmv.f +++ /dev/null @@ -1,342 +0,0 @@ - SUBROUTINE DTBMV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DTBMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular band matrix, with ( k + 1 ) diagonals. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := A'*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with UPLO = 'U' or 'u', K specifies the number of -* super-diagonals of the matrix A. -* On entry with UPLO = 'L' or 'l', K specifies the number of -* sub-diagonals of the matrix A. -* K must satisfy 0 .le. K. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer an upper -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer a lower -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that when DIAG = 'U' or 'u' the elements of the array A -* corresponding to the diagonal elements of the matrix are not -* referenced, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( K.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 7 - ELSE IF( INCX.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTBMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - L = KPLUS1 - J - DO 10, I = MAX( 1, J - K ), J - 1 - X( I ) = X( I ) + TEMP*A( L + I, J ) - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( KPLUS1, J ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - L = KPLUS1 - J - DO 30, I = MAX( 1, J - K ), J - 1 - X( IX ) = X( IX ) + TEMP*A( L + I, J ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( KPLUS1, J ) - END IF - JX = JX + INCX - IF( J.GT.K ) - $ KX = KX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - L = 1 - J - DO 50, I = MIN( N, J + K ), J + 1, -1 - X( I ) = X( I ) + TEMP*A( L + I, J ) - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( 1, J ) - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - L = 1 - J - DO 70, I = MIN( N, J + K ), J + 1, -1 - X( IX ) = X( IX ) + TEMP*A( L + I, J ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( 1, J ) - END IF - JX = JX - INCX - IF( ( N - J ).GE.K ) - $ KX = KX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 100, J = N, 1, -1 - TEMP = X( J ) - L = KPLUS1 - J - IF( NOUNIT ) - $ TEMP = TEMP*A( KPLUS1, J ) - DO 90, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + A( L + I, J )*X( I ) - 90 CONTINUE - X( J ) = TEMP - 100 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 120, J = N, 1, -1 - TEMP = X( JX ) - KX = KX - INCX - IX = KX - L = KPLUS1 - J - IF( NOUNIT ) - $ TEMP = TEMP*A( KPLUS1, J ) - DO 110, I = J - 1, MAX( 1, J - K ), -1 - TEMP = TEMP + A( L + I, J )*X( IX ) - IX = IX - INCX - 110 CONTINUE - X( JX ) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = 1, N - TEMP = X( J ) - L = 1 - J - IF( NOUNIT ) - $ TEMP = TEMP*A( 1, J ) - DO 130, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + A( L + I, J )*X( I ) - 130 CONTINUE - X( J ) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160, J = 1, N - TEMP = X( JX ) - KX = KX + INCX - IX = KX - L = 1 - J - IF( NOUNIT ) - $ TEMP = TEMP*A( 1, J ) - DO 150, I = J + 1, MIN( N, J + K ) - TEMP = TEMP + A( L + I, J )*X( IX ) - IX = IX + INCX - 150 CONTINUE - X( JX ) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTBMV . -* - END diff --git a/ext/blas/dtbsv.f b/ext/blas/dtbsv.f deleted file mode 100644 index d87ed82d5..000000000 --- a/ext/blas/dtbsv.f +++ /dev/null @@ -1,346 +0,0 @@ - SUBROUTINE DTBSV ( UPLO, TRANS, DIAG, N, K, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, K, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DTBSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular band matrix, with ( k + 1 ) -* diagonals. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' A'*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* K - INTEGER. -* On entry with UPLO = 'U' or 'u', K specifies the number of -* super-diagonals of the matrix A. -* On entry with UPLO = 'L' or 'l', K specifies the number of -* sub-diagonals of the matrix A. -* K must satisfy 0 .le. K. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) -* by n part of the array A must contain the upper triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row -* ( k + 1 ) of the array, the first super-diagonal starting at -* position 2 in row k, and so on. The top left k by k triangle -* of the array A is not referenced. -* The following program segment will transfer an upper -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = K + 1 - J -* DO 10, I = MAX( 1, J - K ), J -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) -* by n part of the array A must contain the lower triangular -* band part of the matrix of coefficients, supplied column by -* column, with the leading diagonal of the matrix in row 1 of -* the array, the first sub-diagonal starting at position 1 in -* row 2, and so on. The bottom right k by k triangle of the -* array A is not referenced. -* The following program segment will transfer a lower -* triangular band matrix from conventional full matrix storage -* to band storage: -* -* DO 20, J = 1, N -* M = 1 - J -* DO 10, I = J, MIN( N, J + K ) -* A( M + I, J ) = matrix( I, J ) -* 10 CONTINUE -* 20 CONTINUE -* -* Note that when DIAG = 'U' or 'u' the elements of the array A -* corresponding to the diagonal elements of the matrix are not -* referenced, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* ( k + 1 ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KPLUS1, KX, L - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( K.LT.0 )THEN - INFO = 5 - ELSE IF( LDA.LT.( K + 1 ) )THEN - INFO = 7 - ELSE IF( INCX.EQ.0 )THEN - INFO = 9 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTBSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed by sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - L = KPLUS1 - J - IF( NOUNIT ) - $ X( J ) = X( J )/A( KPLUS1, J ) - TEMP = X( J ) - DO 10, I = J - 1, MAX( 1, J - K ), -1 - X( I ) = X( I ) - TEMP*A( L + I, J ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 40, J = N, 1, -1 - KX = KX - INCX - IF( X( JX ).NE.ZERO )THEN - IX = KX - L = KPLUS1 - J - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( KPLUS1, J ) - TEMP = X( JX ) - DO 30, I = J - 1, MAX( 1, J - K ), -1 - X( IX ) = X( IX ) - TEMP*A( L + I, J ) - IX = IX - INCX - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - L = 1 - J - IF( NOUNIT ) - $ X( J ) = X( J )/A( 1, J ) - TEMP = X( J ) - DO 50, I = J + 1, MIN( N, J + K ) - X( I ) = X( I ) - TEMP*A( L + I, J ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - KX = KX + INCX - IF( X( JX ).NE.ZERO )THEN - IX = KX - L = 1 - J - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( 1, J ) - TEMP = X( JX ) - DO 70, I = J + 1, MIN( N, J + K ) - X( IX ) = X( IX ) - TEMP*A( L + I, J ) - IX = IX + INCX - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A')*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KPLUS1 = K + 1 - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = X( J ) - L = KPLUS1 - J - DO 90, I = MAX( 1, J - K ), J - 1 - TEMP = TEMP - A( L + I, J )*X( I ) - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( KPLUS1, J ) - X( J ) = TEMP - 100 CONTINUE - ELSE - JX = KX - DO 120, J = 1, N - TEMP = X( JX ) - IX = KX - L = KPLUS1 - J - DO 110, I = MAX( 1, J - K ), J - 1 - TEMP = TEMP - A( L + I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( KPLUS1, J ) - X( JX ) = TEMP - JX = JX + INCX - IF( J.GT.K ) - $ KX = KX + INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = N, 1, -1 - TEMP = X( J ) - L = 1 - J - DO 130, I = MIN( N, J + K ), J + 1, -1 - TEMP = TEMP - A( L + I, J )*X( I ) - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( 1, J ) - X( J ) = TEMP - 140 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 160, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - L = 1 - J - DO 150, I = MIN( N, J + K ), J + 1, -1 - TEMP = TEMP - A( L + I, J )*X( IX ) - IX = IX - INCX - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( 1, J ) - X( JX ) = TEMP - JX = JX - INCX - IF( ( N - J ).GE.K ) - $ KX = KX - INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTBSV . -* - END diff --git a/ext/blas/dtpmv.f b/ext/blas/dtpmv.f deleted file mode 100644 index ee11bc1b0..000000000 --- a/ext/blas/dtpmv.f +++ /dev/null @@ -1,299 +0,0 @@ - SUBROUTINE DTPMV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DTPMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular matrix, supplied in packed form. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := A'*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* AP - DOUBLE PRECISION array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -* respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -* respectively, and so on. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced, but are assumed to be unity. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTPMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x:= A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK =1 - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - K = KK - DO 10, I = 1, J - 1 - X( I ) = X( I ) + TEMP*AP( K ) - K = K + 1 - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*AP( KK + J - 1 ) - END IF - KK = KK + J - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, K = KK, KK + J - 2 - X( IX ) = X( IX ) + TEMP*AP( K ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*AP( KK + J - 1 ) - END IF - JX = JX + INCX - KK = KK + J - 40 CONTINUE - END IF - ELSE - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - K = KK - DO 50, I = N, J + 1, -1 - X( I ) = X( I ) + TEMP*AP( K ) - K = K - 1 - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*AP( KK - N + J ) - END IF - KK = KK - ( N - J + 1 ) - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, K = KK, KK - ( N - ( J + 1 ) ), -1 - X( IX ) = X( IX ) + TEMP*AP( K ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*AP( KK - N + J ) - END IF - JX = JX - INCX - KK = KK - ( N - J + 1 ) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 100, J = N, 1, -1 - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - K = KK - 1 - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + AP( K )*X( I ) - K = K - 1 - 90 CONTINUE - X( J ) = TEMP - KK = KK - J - 100 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 120, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 110, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - TEMP = TEMP + AP( K )*X( IX ) - 110 CONTINUE - X( JX ) = TEMP - JX = JX - INCX - KK = KK - J - 120 CONTINUE - END IF - ELSE - KK = 1 - IF( INCX.EQ.1 )THEN - DO 140, J = 1, N - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - K = KK + 1 - DO 130, I = J + 1, N - TEMP = TEMP + AP( K )*X( I ) - K = K + 1 - 130 CONTINUE - X( J ) = TEMP - KK = KK + ( N - J + 1 ) - 140 CONTINUE - ELSE - JX = KX - DO 160, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*AP( KK ) - DO 150, K = KK + 1, KK + N - J - IX = IX + INCX - TEMP = TEMP + AP( K )*X( IX ) - 150 CONTINUE - X( JX ) = TEMP - JX = JX + INCX - KK = KK + ( N - J + 1 ) - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTPMV . -* - END diff --git a/ext/blas/dtpsv.f b/ext/blas/dtpsv.f deleted file mode 100644 index 91930d9fb..000000000 --- a/ext/blas/dtpsv.f +++ /dev/null @@ -1,302 +0,0 @@ - SUBROUTINE DTPSV ( UPLO, TRANS, DIAG, N, AP, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION AP( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DTPSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular matrix, supplied in packed form. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' A'*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* AP - DOUBLE PRECISION array of DIMENSION at least -* ( ( n*( n + 1 ) )/2 ). -* Before entry with UPLO = 'U' or 'u', the array AP must -* contain the upper triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) -* respectively, and so on. -* Before entry with UPLO = 'L' or 'l', the array AP must -* contain the lower triangular matrix packed sequentially, -* column by column, so that AP( 1 ) contains a( 1, 1 ), -* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) -* respectively, and so on. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced, but are assumed to be unity. -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, K, KK, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( INCX.EQ.0 )THEN - INFO = 7 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTPSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of AP are -* accessed sequentially with one pass through AP. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/AP( KK ) - TEMP = X( J ) - K = KK - 1 - DO 10, I = J - 1, 1, -1 - X( I ) = X( I ) - TEMP*AP( K ) - K = K - 1 - 10 CONTINUE - END IF - KK = KK - J - 20 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 40, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/AP( KK ) - TEMP = X( JX ) - IX = JX - DO 30, K = KK - 1, KK - J + 1, -1 - IX = IX - INCX - X( IX ) = X( IX ) - TEMP*AP( K ) - 30 CONTINUE - END IF - JX = JX - INCX - KK = KK - J - 40 CONTINUE - END IF - ELSE - KK = 1 - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/AP( KK ) - TEMP = X( J ) - K = KK + 1 - DO 50, I = J + 1, N - X( I ) = X( I ) - TEMP*AP( K ) - K = K + 1 - 50 CONTINUE - END IF - KK = KK + ( N - J + 1 ) - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/AP( KK ) - TEMP = X( JX ) - IX = JX - DO 70, K = KK + 1, KK + N - J - IX = IX + INCX - X( IX ) = X( IX ) - TEMP*AP( K ) - 70 CONTINUE - END IF - JX = JX + INCX - KK = KK + ( N - J + 1 ) - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - KK = 1 - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = X( J ) - K = KK - DO 90, I = 1, J - 1 - TEMP = TEMP - AP( K )*X( I ) - K = K + 1 - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK + J - 1 ) - X( J ) = TEMP - KK = KK + J - 100 CONTINUE - ELSE - JX = KX - DO 120, J = 1, N - TEMP = X( JX ) - IX = KX - DO 110, K = KK, KK + J - 2 - TEMP = TEMP - AP( K )*X( IX ) - IX = IX + INCX - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK + J - 1 ) - X( JX ) = TEMP - JX = JX + INCX - KK = KK + J - 120 CONTINUE - END IF - ELSE - KK = ( N*( N + 1 ) )/2 - IF( INCX.EQ.1 )THEN - DO 140, J = N, 1, -1 - TEMP = X( J ) - K = KK - DO 130, I = N, J + 1, -1 - TEMP = TEMP - AP( K )*X( I ) - K = K - 1 - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK - N + J ) - X( J ) = TEMP - KK = KK - ( N - J + 1 ) - 140 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 160, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - DO 150, K = KK, KK - ( N - ( J + 1 ) ), -1 - TEMP = TEMP - AP( K )*X( IX ) - IX = IX - INCX - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/AP( KK - N + J ) - X( JX ) = TEMP - JX = JX - INCX - KK = KK - (N - J + 1 ) - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTPSV . -* - END diff --git a/ext/blas/dtrmm.f b/ext/blas/dtrmm.f deleted file mode 100644 index 40c7740c9..000000000 --- a/ext/blas/dtrmm.f +++ /dev/null @@ -1,355 +0,0 @@ - SUBROUTINE DTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - DOUBLE PRECISION ALPHA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DTRMM performs one of the matrix-matrix operations -* -* B := alpha*op( A )*B, or B := alpha*B*op( A ), -* -* where alpha is a scalar, B is an m by n matrix, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A'. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) multiplies B from -* the left or right as follows: -* -* SIDE = 'L' or 'l' B := alpha*op( A )*B. -* -* SIDE = 'R' or 'r' B := alpha*B*op( A ). -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n' op( A ) = A. -* -* TRANSA = 'T' or 't' op( A ) = A'. -* -* TRANSA = 'C' or 'c' op( A ) = A'. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the matrix B, and on exit is overwritten by the -* transformed matrix. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRMM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*A*B. -* - IF( UPPER )THEN - DO 50, J = 1, N - DO 40, K = 1, M - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - DO 30, I = 1, K - 1 - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 30 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - B( K, J ) = TEMP - END IF - 40 CONTINUE - 50 CONTINUE - ELSE - DO 80, J = 1, N - DO 70 K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - TEMP = ALPHA*B( K, J ) - B( K, J ) = TEMP - IF( NOUNIT ) - $ B( K, J ) = B( K, J )*A( K, K ) - DO 60, I = K + 1, M - B( I, J ) = B( I, J ) + TEMP*A( I, K ) - 60 CONTINUE - END IF - 70 CONTINUE - 80 CONTINUE - END IF - ELSE -* -* Form B := alpha*A'*B. -* - IF( UPPER )THEN - DO 110, J = 1, N - DO 100, I = M, 1, -1 - TEMP = B( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 90, K = 1, I - 1 - TEMP = TEMP + A( K, I )*B( K, J ) - 90 CONTINUE - B( I, J ) = ALPHA*TEMP - 100 CONTINUE - 110 CONTINUE - ELSE - DO 140, J = 1, N - DO 130, I = 1, M - TEMP = B( I, J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( I, I ) - DO 120, K = I + 1, M - TEMP = TEMP + A( K, I )*B( K, J ) - 120 CONTINUE - B( I, J ) = ALPHA*TEMP - 130 CONTINUE - 140 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*A. -* - IF( UPPER )THEN - DO 180, J = N, 1, -1 - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 150 CONTINUE - DO 170, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 160, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 160 CONTINUE - END IF - 170 CONTINUE - 180 CONTINUE - ELSE - DO 220, J = 1, N - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 190, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 190 CONTINUE - DO 210, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - TEMP = ALPHA*A( K, J ) - DO 200, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 200 CONTINUE - END IF - 210 CONTINUE - 220 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*A'. -* - IF( UPPER )THEN - DO 260, K = 1, N - DO 240, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - TEMP = ALPHA*A( J, K ) - DO 230, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 230 CONTINUE - END IF - 240 CONTINUE - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - IF( TEMP.NE.ONE )THEN - DO 250, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 250 CONTINUE - END IF - 260 CONTINUE - ELSE - DO 300, K = N, 1, -1 - DO 280, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - TEMP = ALPHA*A( J, K ) - DO 270, I = 1, M - B( I, J ) = B( I, J ) + TEMP*B( I, K ) - 270 CONTINUE - END IF - 280 CONTINUE - TEMP = ALPHA - IF( NOUNIT ) - $ TEMP = TEMP*A( K, K ) - IF( TEMP.NE.ONE )THEN - DO 290, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 290 CONTINUE - END IF - 300 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMM . -* - END diff --git a/ext/blas/dtrmv.f b/ext/blas/dtrmv.f deleted file mode 100644 index 3d5c61b20..000000000 --- a/ext/blas/dtrmv.f +++ /dev/null @@ -1,286 +0,0 @@ - SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DTRMV performs one of the matrix-vector operations -* -* x := A*x, or x := A'*x, -* -* where x is an n element vector and A is an n by n unit, or non-unit, -* upper or lower triangular matrix. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the operation to be performed as -* follows: -* -* TRANS = 'N' or 'n' x := A*x. -* -* TRANS = 'T' or 't' x := A'*x. -* -* TRANS = 'C' or 'c' x := A'*x. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element vector x. On exit, X is overwritten with the -* tranformed vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRMV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := A*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = 1, N - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 10, I = 1, J - 1 - X( I ) = X( I ) + TEMP*A( I, J ) - 10 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 20 CONTINUE - ELSE - JX = KX - DO 40, J = 1, N - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 30, I = 1, J - 1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX + INCX - 30 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX + INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - TEMP = X( J ) - DO 50, I = N, J + 1, -1 - X( I ) = X( I ) + TEMP*A( I, J ) - 50 CONTINUE - IF( NOUNIT ) - $ X( J ) = X( J )*A( J, J ) - END IF - 60 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 80, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - TEMP = X( JX ) - IX = KX - DO 70, I = N, J + 1, -1 - X( IX ) = X( IX ) + TEMP*A( I, J ) - IX = IX - INCX - 70 CONTINUE - IF( NOUNIT ) - $ X( JX ) = X( JX )*A( J, J ) - END IF - JX = JX - INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := A'*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 100, J = N, 1, -1 - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 90, I = J - 1, 1, -1 - TEMP = TEMP + A( I, J )*X( I ) - 90 CONTINUE - X( J ) = TEMP - 100 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 120, J = N, 1, -1 - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 110, I = J - 1, 1, -1 - IX = IX - INCX - TEMP = TEMP + A( I, J )*X( IX ) - 110 CONTINUE - X( JX ) = TEMP - JX = JX - INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = 1, N - TEMP = X( J ) - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 130, I = J + 1, N - TEMP = TEMP + A( I, J )*X( I ) - 130 CONTINUE - X( J ) = TEMP - 140 CONTINUE - ELSE - JX = KX - DO 160, J = 1, N - TEMP = X( JX ) - IX = JX - IF( NOUNIT ) - $ TEMP = TEMP*A( J, J ) - DO 150, I = J + 1, N - IX = IX + INCX - TEMP = TEMP + A( I, J )*X( IX ) - 150 CONTINUE - X( JX ) = TEMP - JX = JX + INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRMV . -* - END diff --git a/ext/blas/dtrsm.f b/ext/blas/dtrsm.f deleted file mode 100644 index e8425142b..000000000 --- a/ext/blas/dtrsm.f +++ /dev/null @@ -1,378 +0,0 @@ - SUBROUTINE DTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, - $ B, LDB ) -* .. Scalar Arguments .. - CHARACTER*1 SIDE, UPLO, TRANSA, DIAG - INTEGER M, N, LDA, LDB - DOUBLE PRECISION ALPHA -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DTRSM solves one of the matrix equations -* -* op( A )*X = alpha*B, or X*op( A ) = alpha*B, -* -* where alpha is a scalar, X and B are m by n matrices, A is a unit, or -* non-unit, upper or lower triangular matrix and op( A ) is one of -* -* op( A ) = A or op( A ) = A'. -* -* The matrix X is overwritten on B. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* On entry, SIDE specifies whether op( A ) appears on the left -* or right of X as follows: -* -* SIDE = 'L' or 'l' op( A )*X = alpha*B. -* -* SIDE = 'R' or 'r' X*op( A ) = alpha*B. -* -* Unchanged on exit. -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix A is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANSA - CHARACTER*1. -* On entry, TRANSA specifies the form of op( A ) to be used in -* the matrix multiplication as follows: -* -* TRANSA = 'N' or 'n' op( A ) = A. -* -* TRANSA = 'T' or 't' op( A ) = A'. -* -* TRANSA = 'C' or 'c' op( A ) = A'. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit triangular -* as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* M - INTEGER. -* On entry, M specifies the number of rows of B. M must be at -* least zero. -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the number of columns of B. N must be -* at least zero. -* Unchanged on exit. -* -* ALPHA - DOUBLE PRECISION. -* On entry, ALPHA specifies the scalar alpha. When alpha is -* zero then A is not referenced and B need not be set before -* entry. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m -* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. -* Before entry with UPLO = 'U' or 'u', the leading k by k -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading k by k -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. When SIDE = 'L' or 'l' then -* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' -* then LDA must be at least max( 1, n ). -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). -* Before entry, the leading m by n part of the array B must -* contain the right-hand side matrix B, and on exit is -* overwritten by the solution matrix X. -* -* LDB - INTEGER. -* On entry, LDB specifies the first dimension of B as declared -* in the calling (sub) program. LDB must be at least -* max( 1, m ). -* Unchanged on exit. -* -* -* Level 3 Blas routine. -* -* -* -- Written on 8-February-1989. -* Jack Dongarra, Argonne National Laboratory. -* Iain Duff, AERE Harwell. -* Jeremy Du Croz, Numerical Algorithms Group Ltd. -* Sven Hammarling, Numerical Algorithms Group Ltd. -* -* -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. Local Scalars .. - LOGICAL LSIDE, NOUNIT, UPPER - INTEGER I, INFO, J, K, NROWA - DOUBLE PRECISION TEMP -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - LSIDE = LSAME( SIDE , 'L' ) - IF( LSIDE )THEN - NROWA = M - ELSE - NROWA = N - END IF - NOUNIT = LSAME( DIAG , 'N' ) - UPPER = LSAME( UPLO , 'U' ) -* - INFO = 0 - IF( ( .NOT.LSIDE ).AND. - $ ( .NOT.LSAME( SIDE , 'R' ) ) )THEN - INFO = 1 - ELSE IF( ( .NOT.UPPER ).AND. - $ ( .NOT.LSAME( UPLO , 'L' ) ) )THEN - INFO = 2 - ELSE IF( ( .NOT.LSAME( TRANSA, 'N' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'T' ) ).AND. - $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN - INFO = 3 - ELSE IF( ( .NOT.LSAME( DIAG , 'U' ) ).AND. - $ ( .NOT.LSAME( DIAG , 'N' ) ) )THEN - INFO = 4 - ELSE IF( M .LT.0 )THEN - INFO = 5 - ELSE IF( N .LT.0 )THEN - INFO = 6 - ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN - INFO = 9 - ELSE IF( LDB.LT.MAX( 1, M ) )THEN - INFO = 11 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRSM ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* -* And when alpha.eq.zero. -* - IF( ALPHA.EQ.ZERO )THEN - DO 20, J = 1, N - DO 10, I = 1, M - B( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - RETURN - END IF -* -* Start the operations. -* - IF( LSIDE )THEN - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*inv( A )*B. -* - IF( UPPER )THEN - DO 60, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 30, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 30 CONTINUE - END IF - DO 50, K = M, 1, -1 - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 40, I = 1, K - 1 - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 40 CONTINUE - END IF - 50 CONTINUE - 60 CONTINUE - ELSE - DO 100, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 70, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 70 CONTINUE - END IF - DO 90 K = 1, M - IF( B( K, J ).NE.ZERO )THEN - IF( NOUNIT ) - $ B( K, J ) = B( K, J )/A( K, K ) - DO 80, I = K + 1, M - B( I, J ) = B( I, J ) - B( K, J )*A( I, K ) - 80 CONTINUE - END IF - 90 CONTINUE - 100 CONTINUE - END IF - ELSE -* -* Form B := alpha*inv( A' )*B. -* - IF( UPPER )THEN - DO 130, J = 1, N - DO 120, I = 1, M - TEMP = ALPHA*B( I, J ) - DO 110, K = 1, I - 1 - TEMP = TEMP - A( K, I )*B( K, J ) - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 120 CONTINUE - 130 CONTINUE - ELSE - DO 160, J = 1, N - DO 150, I = M, 1, -1 - TEMP = ALPHA*B( I, J ) - DO 140, K = I + 1, M - TEMP = TEMP - A( K, I )*B( K, J ) - 140 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( I, I ) - B( I, J ) = TEMP - 150 CONTINUE - 160 CONTINUE - END IF - END IF - ELSE - IF( LSAME( TRANSA, 'N' ) )THEN -* -* Form B := alpha*B*inv( A ). -* - IF( UPPER )THEN - DO 210, J = 1, N - IF( ALPHA.NE.ONE )THEN - DO 170, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 170 CONTINUE - END IF - DO 190, K = 1, J - 1 - IF( A( K, J ).NE.ZERO )THEN - DO 180, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 180 CONTINUE - END IF - 190 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 200, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 200 CONTINUE - END IF - 210 CONTINUE - ELSE - DO 260, J = N, 1, -1 - IF( ALPHA.NE.ONE )THEN - DO 220, I = 1, M - B( I, J ) = ALPHA*B( I, J ) - 220 CONTINUE - END IF - DO 240, K = J + 1, N - IF( A( K, J ).NE.ZERO )THEN - DO 230, I = 1, M - B( I, J ) = B( I, J ) - A( K, J )*B( I, K ) - 230 CONTINUE - END IF - 240 CONTINUE - IF( NOUNIT )THEN - TEMP = ONE/A( J, J ) - DO 250, I = 1, M - B( I, J ) = TEMP*B( I, J ) - 250 CONTINUE - END IF - 260 CONTINUE - END IF - ELSE -* -* Form B := alpha*B*inv( A' ). -* - IF( UPPER )THEN - DO 310, K = N, 1, -1 - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 270, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 270 CONTINUE - END IF - DO 290, J = 1, K - 1 - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 280, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 280 CONTINUE - END IF - 290 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 300, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 300 CONTINUE - END IF - 310 CONTINUE - ELSE - DO 360, K = 1, N - IF( NOUNIT )THEN - TEMP = ONE/A( K, K ) - DO 320, I = 1, M - B( I, K ) = TEMP*B( I, K ) - 320 CONTINUE - END IF - DO 340, J = K + 1, N - IF( A( J, K ).NE.ZERO )THEN - TEMP = A( J, K ) - DO 330, I = 1, M - B( I, J ) = B( I, J ) - TEMP*B( I, K ) - 330 CONTINUE - END IF - 340 CONTINUE - IF( ALPHA.NE.ONE )THEN - DO 350, I = 1, M - B( I, K ) = ALPHA*B( I, K ) - 350 CONTINUE - END IF - 360 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSM . -* - END diff --git a/ext/blas/dtrsv.f b/ext/blas/dtrsv.f deleted file mode 100644 index 9c3e90a97..000000000 --- a/ext/blas/dtrsv.f +++ /dev/null @@ -1,289 +0,0 @@ - SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, LDA, N - CHARACTER*1 DIAG, TRANS, UPLO -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DTRSV solves one of the systems of equations -* -* A*x = b, or A'*x = b, -* -* where b and x are n element vectors and A is an n by n unit, or -* non-unit, upper or lower triangular matrix. -* -* No test for singularity or near-singularity is included in this -* routine. Such tests must be performed before calling this routine. -* -* Parameters -* ========== -* -* UPLO - CHARACTER*1. -* On entry, UPLO specifies whether the matrix is an upper or -* lower triangular matrix as follows: -* -* UPLO = 'U' or 'u' A is an upper triangular matrix. -* -* UPLO = 'L' or 'l' A is a lower triangular matrix. -* -* Unchanged on exit. -* -* TRANS - CHARACTER*1. -* On entry, TRANS specifies the equations to be solved as -* follows: -* -* TRANS = 'N' or 'n' A*x = b. -* -* TRANS = 'T' or 't' A'*x = b. -* -* TRANS = 'C' or 'c' A'*x = b. -* -* Unchanged on exit. -* -* DIAG - CHARACTER*1. -* On entry, DIAG specifies whether or not A is unit -* triangular as follows: -* -* DIAG = 'U' or 'u' A is assumed to be unit triangular. -* -* DIAG = 'N' or 'n' A is not assumed to be unit -* triangular. -* -* Unchanged on exit. -* -* N - INTEGER. -* On entry, N specifies the order of the matrix A. -* N must be at least zero. -* Unchanged on exit. -* -* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). -* Before entry with UPLO = 'U' or 'u', the leading n by n -* upper triangular part of the array A must contain the upper -* triangular matrix and the strictly lower triangular part of -* A is not referenced. -* Before entry with UPLO = 'L' or 'l', the leading n by n -* lower triangular part of the array A must contain the lower -* triangular matrix and the strictly upper triangular part of -* A is not referenced. -* Note that when DIAG = 'U' or 'u', the diagonal elements of -* A are not referenced either, but are assumed to be unity. -* Unchanged on exit. -* -* LDA - INTEGER. -* On entry, LDA specifies the first dimension of A as declared -* in the calling (sub) program. LDA must be at least -* max( 1, n ). -* Unchanged on exit. -* -* X - DOUBLE PRECISION array of dimension at least -* ( 1 + ( n - 1 )*abs( INCX ) ). -* Before entry, the incremented array X must contain the n -* element right-hand side vector b. On exit, X is overwritten -* with the solution vector x. -* -* INCX - INTEGER. -* On entry, INCX specifies the increment for the elements of -* X. INCX must not be zero. -* Unchanged on exit. -* -* -* Level 2 Blas routine. -* -* -- Written on 22-October-1986. -* Jack Dongarra, Argonne National Lab. -* Jeremy Du Croz, Nag Central Office. -* Sven Hammarling, Nag Central Office. -* Richard Hanson, Sandia National Labs. -* -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, INFO, IX, J, JX, KX - LOGICAL NOUNIT -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. External Subroutines .. - EXTERNAL XERBLA -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF ( .NOT.LSAME( UPLO , 'U' ).AND. - $ .NOT.LSAME( UPLO , 'L' ) )THEN - INFO = 1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. - $ .NOT.LSAME( TRANS, 'T' ).AND. - $ .NOT.LSAME( TRANS, 'C' ) )THEN - INFO = 2 - ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. - $ .NOT.LSAME( DIAG , 'N' ) )THEN - INFO = 3 - ELSE IF( N.LT.0 )THEN - INFO = 4 - ELSE IF( LDA.LT.MAX( 1, N ) )THEN - INFO = 6 - ELSE IF( INCX.EQ.0 )THEN - INFO = 8 - END IF - IF( INFO.NE.0 )THEN - CALL XERBLA( 'DTRSV ', INFO ) - RETURN - END IF -* -* Quick return if possible. -* - IF( N.EQ.0 ) - $ RETURN -* - NOUNIT = LSAME( DIAG, 'N' ) -* -* Set up the start point in X if the increment is not unity. This -* will be ( N - 1 )*INCX too small for descending loops. -* - IF( INCX.LE.0 )THEN - KX = 1 - ( N - 1 )*INCX - ELSE IF( INCX.NE.1 )THEN - KX = 1 - END IF -* -* Start the operations. In this version the elements of A are -* accessed sequentially with one pass through A. -* - IF( LSAME( TRANS, 'N' ) )THEN -* -* Form x := inv( A )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 20, J = N, 1, -1 - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 10, I = J - 1, 1, -1 - X( I ) = X( I ) - TEMP*A( I, J ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE - JX = KX + ( N - 1 )*INCX - DO 40, J = N, 1, -1 - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - TEMP = X( JX ) - IX = JX - DO 30, I = J - 1, 1, -1 - IX = IX - INCX - X( IX ) = X( IX ) - TEMP*A( I, J ) - 30 CONTINUE - END IF - JX = JX - INCX - 40 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 60, J = 1, N - IF( X( J ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( J ) = X( J )/A( J, J ) - TEMP = X( J ) - DO 50, I = J + 1, N - X( I ) = X( I ) - TEMP*A( I, J ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE - JX = KX - DO 80, J = 1, N - IF( X( JX ).NE.ZERO )THEN - IF( NOUNIT ) - $ X( JX ) = X( JX )/A( J, J ) - TEMP = X( JX ) - IX = JX - DO 70, I = J + 1, N - IX = IX + INCX - X( IX ) = X( IX ) - TEMP*A( I, J ) - 70 CONTINUE - END IF - JX = JX + INCX - 80 CONTINUE - END IF - END IF - ELSE -* -* Form x := inv( A' )*x. -* - IF( LSAME( UPLO, 'U' ) )THEN - IF( INCX.EQ.1 )THEN - DO 100, J = 1, N - TEMP = X( J ) - DO 90, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( I ) - 90 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( J ) = TEMP - 100 CONTINUE - ELSE - JX = KX - DO 120, J = 1, N - TEMP = X( JX ) - IX = KX - DO 110, I = 1, J - 1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX + INCX - 110 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( JX ) = TEMP - JX = JX + INCX - 120 CONTINUE - END IF - ELSE - IF( INCX.EQ.1 )THEN - DO 140, J = N, 1, -1 - TEMP = X( J ) - DO 130, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( I ) - 130 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( J ) = TEMP - 140 CONTINUE - ELSE - KX = KX + ( N - 1 )*INCX - JX = KX - DO 160, J = N, 1, -1 - TEMP = X( JX ) - IX = KX - DO 150, I = N, J + 1, -1 - TEMP = TEMP - A( I, J )*X( IX ) - IX = IX - INCX - 150 CONTINUE - IF( NOUNIT ) - $ TEMP = TEMP/A( J, J ) - X( JX ) = TEMP - JX = JX - INCX - 160 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DTRSV . -* - END diff --git a/ext/blas/dzasum.f b/ext/blas/dzasum.f deleted file mode 100644 index d21c1ffc9..000000000 --- a/ext/blas/dzasum.f +++ /dev/null @@ -1,34 +0,0 @@ - double precision function dzasum(n,zx,incx) -c -c takes the sum of the absolute values. -c jack dongarra, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*) - double precision stemp,dcabs1 - integer i,incx,ix,n -c - dzasum = 0.0d0 - stemp = 0.0d0 - if( n.le.0 .or. incx.le.0 )return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - do 10 i = 1,n - stemp = stemp + dcabs1(zx(ix)) - ix = ix + incx - 10 continue - dzasum = stemp - return -c -c code for increment equal to 1 -c - 20 do 30 i = 1,n - stemp = stemp + dcabs1(zx(i)) - 30 continue - dzasum = stemp - return - end diff --git a/ext/blas/dznrm2.f b/ext/blas/dznrm2.f deleted file mode 100644 index 205ce3932..000000000 --- a/ext/blas/dznrm2.f +++ /dev/null @@ -1,67 +0,0 @@ - DOUBLE PRECISION FUNCTION DZNRM2( N, X, INCX ) -* .. Scalar Arguments .. - INTEGER INCX, N -* .. Array Arguments .. - COMPLEX*16 X( * ) -* .. -* -* DZNRM2 returns the euclidean norm of a vector via the function -* name, so that -* -* DZNRM2 := sqrt( conjg( x' )*x ) -* -* -* -* -- This version written on 25-October-1982. -* Modified on 14-October-1993 to inline the call to ZLASSQ. -* Sven Hammarling, Nag Ltd. -* -* -* .. Parameters .. - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION NORM, SCALE, SSQ, TEMP -* .. Intrinsic Functions .. - INTRINSIC ABS, DIMAG, DBLE, SQRT -* .. -* .. Executable Statements .. - IF( N.LT.1 .OR. INCX.LT.1 )THEN - NORM = ZERO - ELSE - SCALE = ZERO - SSQ = ONE -* The following loop is equivalent to this call to the LAPACK -* auxiliary routine: -* CALL ZLASSQ( N, X, INCX, SCALE, SSQ ) -* - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - IF( DBLE( X( IX ) ).NE.ZERO )THEN - TEMP = ABS( DBLE( X( IX ) ) ) - IF( SCALE.LT.TEMP )THEN - SSQ = ONE + SSQ*( SCALE/TEMP )**2 - SCALE = TEMP - ELSE - SSQ = SSQ + ( TEMP/SCALE )**2 - END IF - END IF - IF( DIMAG( X( IX ) ).NE.ZERO )THEN - TEMP = ABS( DIMAG( X( IX ) ) ) - IF( SCALE.LT.TEMP )THEN - SSQ = ONE + SSQ*( SCALE/TEMP )**2 - SCALE = TEMP - ELSE - SSQ = SSQ + ( TEMP/SCALE )**2 - END IF - END IF - 10 CONTINUE - NORM = SCALE * SQRT( SSQ ) - END IF -* - DZNRM2 = NORM - RETURN -* -* End of DZNRM2. -* - END diff --git a/ext/blas/icamax.f b/ext/blas/icamax.f deleted file mode 100644 index b13d4904f..000000000 --- a/ext/blas/icamax.f +++ /dev/null @@ -1,43 +0,0 @@ - integer function icamax(n,cx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - complex cx(*) - real smax - integer i,incx,ix,n - complex zdum - real cabs1 - cabs1(zdum) = abs(real(zdum)) + abs(aimag(zdum)) -c - icamax = 0 - if( n.lt.1 .or. incx.le.0 ) return - icamax = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smax = cabs1(cx(1)) - ix = ix + incx - do 10 i = 2,n - if(cabs1(cx(ix)).le.smax) go to 5 - icamax = i - smax = cabs1(cx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smax = cabs1(cx(1)) - do 30 i = 2,n - if(cabs1(cx(i)).le.smax) go to 30 - icamax = i - smax = cabs1(cx(i)) - 30 continue - return - end diff --git a/ext/blas/idamax.f b/ext/blas/idamax.f deleted file mode 100644 index 59d80dc41..000000000 --- a/ext/blas/idamax.f +++ /dev/null @@ -1,39 +0,0 @@ - integer function idamax(n,dx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double precision dx(*),dmax - integer i,incx,ix,n -c - idamax = 0 - if( n.lt.1 .or. incx.le.0 ) return - idamax = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - dmax = dabs(dx(1)) - ix = ix + incx - do 10 i = 2,n - if(dabs(dx(ix)).le.dmax) go to 5 - idamax = i - dmax = dabs(dx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 dmax = dabs(dx(1)) - do 30 i = 2,n - if(dabs(dx(i)).le.dmax) go to 30 - idamax = i - dmax = dabs(dx(i)) - 30 continue - return - end diff --git a/ext/blas/isamax.f b/ext/blas/isamax.f deleted file mode 100644 index a649e0281..000000000 --- a/ext/blas/isamax.f +++ /dev/null @@ -1,39 +0,0 @@ - integer function isamax(n,sx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, linpack, 3/11/78. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - real sx(*),smax - integer i,incx,ix,n -c - isamax = 0 - if( n.lt.1 .or. incx.le.0 ) return - isamax = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smax = abs(sx(1)) - ix = ix + incx - do 10 i = 2,n - if(abs(sx(ix)).le.smax) go to 5 - isamax = i - smax = abs(sx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smax = abs(sx(1)) - do 30 i = 2,n - if(abs(sx(i)).le.smax) go to 30 - isamax = i - smax = abs(sx(i)) - 30 continue - return - end diff --git a/ext/blas/izamax.f b/ext/blas/izamax.f deleted file mode 100644 index ec14f827d..000000000 --- a/ext/blas/izamax.f +++ /dev/null @@ -1,41 +0,0 @@ - integer function izamax(n,zx,incx) -c -c finds the index of element having max. absolute value. -c jack dongarra, 1/15/85. -c modified 3/93 to return if incx .le. 0. -c modified 12/3/93, array(1) declarations changed to array(*) -c - double complex zx(*) - double precision smax - integer i,incx,ix,n - double precision dcabs1 -c - izamax = 0 - if( n.lt.1 .or. incx.le.0 )return - izamax = 1 - if(n.eq.1)return - if(incx.eq.1)go to 20 -c -c code for increment not equal to 1 -c - ix = 1 - smax = dcabs1(zx(1)) - ix = ix + incx - do 10 i = 2,n - if(dcabs1(zx(ix)).le.smax) go to 5 - izamax = i - smax = dcabs1(zx(ix)) - 5 ix = ix + incx - 10 continue - return -c -c code for increment equal to 1 -c - 20 smax = dcabs1(zx(1)) - do 30 i = 2,n - if(dcabs1(zx(i)).le.smax) go to 30 - izamax = i - smax = dcabs1(zx(i)) - 30 continue - return - end diff --git a/ext/blas/xerbla.f b/ext/blas/xerbla.f deleted file mode 100644 index 18100082c..000000000 --- a/ext/blas/xerbla.f +++ /dev/null @@ -1,43 +0,0 @@ - SUBROUTINE XERBLA( SRNAME, INFO ) -* -* -- LAPACK auxiliary routine (preliminary version) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER*6 SRNAME - INTEGER INFO -* .. -* -* Purpose -* ======= -* -* XERBLA is an error handler for the LAPACK routines. -* It is called by an LAPACK routine if an input parameter has an -* invalid value. A message is printed and execution stops. -* -* Installers may consider modifying the STOP statement in order to -* call system-specific exception-handling facilities. -* -* Arguments -* ========= -* -* SRNAME (input) CHARACTER*6 -* The name of the routine which called XERBLA. -* -* INFO (input) INTEGER -* The position of the invalid parameter in the parameter list -* of the calling routine. -* -* - WRITE( *, FMT = 9999 )SRNAME, INFO -* - STOP -* - 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', - $ 'an illegal value' ) -* -* End of XERBLA -* - END diff --git a/ext/f2c_blas/blaswrap.h b/ext/f2c_blas/blaswrap.h deleted file mode 100644 index cbca44b4c..000000000 --- a/ext/f2c_blas/blaswrap.h +++ /dev/null @@ -1,162 +0,0 @@ -/* CLAPACK 3.0 BLAS wrapper macros - * Feb 5, 2000 - */ - -#ifndef __BLASWRAP_H -#define __BLASWRAP_H -/* - * HKM -> Defined NO_BLAS_WRAP so raw blas names will be - * used instead of wrappers. - */ -#define NO_BLAS_WRAP -#ifndef NO_BLAS_WRAP - -/* BLAS1 routines */ -#define srotg_ f2c_srotg -#define drotg_ f2c_drotg -#define srotmg_ f2c_srotmg -#define drotmg_ f2c_drotmg -#define srot_ f2c_srot -#define drot_ f2c_drot -#define srotm_ f2c_srotm -#define drotm_ f2c_drotm -#define sswap_ f2c_sswap -#define dswap_ f2c_dswap -#define cswap_ f2c_cswap -#define zswap_ f2c_zswap -#define sscal_ f2c_sscal -#define dscal_ f2c_dscal -#define cscal_ f2c_cscal -#define zscal_ f2c_zscal -#define csscal_ f2c_csscal -#define zdscal_ f2c_zdscal -#define scopy_ f2c_scopy -#define dcopy_ f2c_dcopy -#define ccopy_ f2c_ccopy -#define zcopy_ f2c_zcopy -#define saxpy_ f2c_saxpy -#define daxpy_ f2c_daxpy -#define caxpy_ f2c_caxpy -#define zaxpy_ f2c_zaxpy -#define sdot_ f2c_sdot -#define ddot_ f2c_ddot -#define cdotu_ f2c_cdotu -#define zdotu_ f2c_zdotu -#define cdotc_ f2c_cdotc -#define zdotc_ f2c_zdotc -#define snrm2_ f2c_snrm2 -#define dnrm2_ f2c_dnrm2 -#define scnrm2_ f2c_scnrm2 -#define dznrm2_ f2c_dznrm2 -#define sasum_ f2c_sasum -#define dasum_ f2c_dasum -#define scasum_ f2c_scasum -#define dzasum_ f2c_dzasum -#define isamax_ f2c_isamax -#define idamax_ f2c_idamax -#define icamax_ f2c_icamax -#define izamax_ f2c_izamax - -/* BLAS2 routines */ -#define sgemv_ f2c_sgemv -#define dgemv_ f2c_dgemv -#define cgemv_ f2c_cgemv -#define zgemv_ f2c_zgemv -#define sgbmv_ f2c_sgbmv -#define dgbmv_ f2c_dgbmv -#define cgbmv_ f2c_cgbmv -#define zgbmv_ f2c_zgbmv -#define chemv_ f2c_chemv -#define zhemv_ f2c_zhemv -#define chbmv_ f2c_chbmv -#define zhbmv_ f2c_zhbmv -#define chpmv_ f2c_chpmv -#define zhpmv_ f2c_zhpmv -#define ssymv_ f2c_ssymv -#define dsymv_ f2c_dsymv -#define ssbmv_ f2c_ssbmv -#define dsbmv_ f2c_dsbmv -#define sspmv_ f2c_sspmv -#define dspmv_ f2c_dspmv -#define strmv_ f2c_strmv -#define dtrmv_ f2c_dtrmv -#define ctrmv_ f2c_ctrmv -#define ztrmv_ f2c_ztrmv -#define stbmv_ f2c_stbmv -#define dtbmv_ f2c_dtbmv -#define ctbmv_ f2c_ctbmv -#define ztbmv_ f2c_ztbmv -#define stpmv_ f2c_stpmv -#define dtpmv_ f2c_dtpmv -#define ctpmv_ f2c_ctpmv -#define ztpmv_ f2c_ztpmv -#define strsv_ f2c_strsv -#define dtrsv_ f2c_dtrsv -#define ctrsv_ f2c_ctrsv -#define ztrsv_ f2c_ztrsv -#define stbsv_ f2c_stbsv -#define dtbsv_ f2c_dtbsv -#define ctbsv_ f2c_ctbsv -#define ztbsv_ f2c_ztbsv -#define stpsv_ f2c_stpsv -#define dtpsv_ f2c_dtpsv -#define ctpsv_ f2c_ctpsv -#define ztpsv_ f2c_ztpsv -#define sger_ f2c_sger -#define dger_ f2c_dger -#define cgeru_ f2c_cgeru -#define zgeru_ f2c_zgeru -#define cgerc_ f2c_cgerc -#define zgerc_ f2c_zgerc -#define cher_ f2c_cher -#define zher_ f2c_zher -#define chpr_ f2c_chpr -#define zhpr_ f2c_zhpr -#define cher2_ f2c_cher2 -#define zher2_ f2c_zher2 -#define chpr2_ f2c_chpr2 -#define zhpr2_ f2c_zhpr2 -#define ssyr_ f2c_ssyr -#define dsyr_ f2c_dsyr -#define sspr_ f2c_sspr -#define dspr_ f2c_dspr -#define ssyr2_ f2c_ssyr2 -#define dsyr2_ f2c_dsyr2 -#define sspr2_ f2c_sspr2 -#define dspr2_ f2c_dspr2 - -/* BLAS3 routines */ -#define sgemm_ f2c_sgemm -#define dgemm_ f2c_dgemm -#define cgemm_ f2c_cgemm -#define zgemm_ f2c_zgemm -#define ssymm_ f2c_ssymm -#define dsymm_ f2c_dsymm -#define csymm_ f2c_csymm -#define zsymm_ f2c_zsymm -#define chemm_ f2c_chemm -#define zhemm_ f2c_zhemm -#define ssyrk_ f2c_ssyrk -#define dsyrk_ f2c_dsyrk -#define csyrk_ f2c_csyrk -#define zsyrk_ f2c_zsyrk -#define cherk_ f2c_cherk -#define zherk_ f2c_zherk -#define ssyr2k_ f2c_ssyr2k -#define dsyr2k_ f2c_dsyr2k -#define csyr2k_ f2c_csyr2k -#define zsyr2k_ f2c_zsyr2k -#define cher2k_ f2c_cher2k -#define zher2k_ f2c_zher2k -#define strmm_ f2c_strmm -#define dtrmm_ f2c_dtrmm -#define ctrmm_ f2c_ctrmm -#define ztrmm_ f2c_ztrmm -#define strsm_ f2c_strsm -#define dtrsm_ f2c_dtrsm -#define ctrsm_ f2c_ctrsm -#define ztrsm_ f2c_ztrsm - -#endif /* NO_BLAS_WRAP */ - -#endif /* __BLASWRAP_H */ diff --git a/ext/f2c_blas/dasum.c b/ext/f2c_blas/dasum.c deleted file mode 100644 index 7eb8ed66f..000000000 --- a/ext/f2c_blas/dasum.c +++ /dev/null @@ -1,73 +0,0 @@ -#include "blaswrap.h" -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -doublereal dasum_(integer *n, doublereal *dx, integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - doublereal ret_val, d__1, d__2, d__3, d__4, d__5, d__6; - /* Local variables */ - static integer i__, m; - static doublereal dtemp; - static integer nincx, mp1; -/* takes the sum of the absolute values. - jack dongarra, linpack, 3/11/78. - modified 3/93 to return if incx .le. 0. - modified 12/3/93, array(1) declarations changed to array(*) - Parameter adjustments */ - --dx; - /* Function Body */ - ret_val = 0.; - dtemp = 0.; - if (*n <= 0 || *incx <= 0) { - return ret_val; - } - if (*incx == 1) { - goto L20; - } -/* code for increment not equal to 1 */ - nincx = *n * *incx; - i__1 = nincx; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - dtemp += (d__1 = dx[i__], abs(d__1)); -/* L10: */ - } - ret_val = dtemp; - return ret_val; -/* code for increment equal to 1 - clean-up loop */ -L20: - m = *n % 6; - if (m == 0) { - goto L40; - } - i__2 = m; - for (i__ = 1; i__ <= i__2; ++i__) { - dtemp += (d__1 = dx[i__], abs(d__1)); -/* L30: */ - } - if (*n < 6) { - goto L60; - } -L40: - mp1 = m + 1; - i__2 = *n; - for (i__ = mp1; i__ <= i__2; i__ += 6) { - dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1], - abs(d__2)) + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 = dx[i__ - + 3], abs(d__4)) + (d__5 = dx[i__ + 4], abs(d__5)) + (d__6 = - dx[i__ + 5], abs(d__6)); -/* L50: */ - } -L60: - ret_val = dtemp; - return ret_val; -} /* dasum_ */ -#ifdef __cplusplus -} -#endif - diff --git a/ext/f2c_blas/daxpy.c b/ext/f2c_blas/daxpy.c deleted file mode 100644 index 4323ff90e..000000000 --- a/ext/f2c_blas/daxpy.c +++ /dev/null @@ -1,91 +0,0 @@ -#include "blaswrap.h" -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int daxpy_(integer *n, doublereal *da, doublereal *dx, - integer *incx, doublereal *dy, integer *incy) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - static integer i__, m, ix, iy, mp1; - - -/* constant times a vector plus a vector. */ -/* uses unrolled loops for increments equal to one. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified 12/3/93, array(1) declarations changed to array(*) */ - - - /* Parameter adjustments */ - --dy; - --dx; - - /* Function Body */ - if (*n <= 0) { - return 0; - } - if (*da == 0.) { - return 0; - } - if (*incx == 1 && *incy == 1) { - goto L20; - } - -/* code for unequal increments or equal increments */ -/* not equal to 1 */ - - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dy[iy] += *da * dx[ix]; - ix += *incx; - iy += *incy; -/* L10: */ - } - return 0; - -/* code for both increments equal to 1 */ - - -/* clean-up loop */ - -L20: - m = *n % 4; - if (m == 0) { - goto L40; - } - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dy[i__] += *da * dx[i__]; -/* L30: */ - } - if (*n < 4) { - return 0; - } -L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 4) { - dy[i__] += *da * dx[i__]; - dy[i__ + 1] += *da * dx[i__ + 1]; - dy[i__ + 2] += *da * dx[i__ + 2]; - dy[i__ + 3] += *da * dx[i__ + 3]; -/* L50: */ - } - return 0; -} /* daxpy_ */ - -#ifdef __cplusplus - } -#endif diff --git a/ext/f2c_blas/dcabs1.c b/ext/f2c_blas/dcabs1.c deleted file mode 100644 index 09876948e..000000000 --- a/ext/f2c_blas/dcabs1.c +++ /dev/null @@ -1,24 +0,0 @@ -#include "blaswrap.h" -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -doublereal dcabs1_(doublecomplex *z__) -{ - /* System generated locals */ - doublereal ret_val; - static doublecomplex equiv_0[1]; - /* Local variables */ -#define t ((doublereal *)equiv_0) -#define zz (equiv_0) - zz->r = z__->r, zz->i = z__->i; - ret_val = abs(t[0]) + abs(t[1]); - return ret_val; -} /* dcabs1_ */ -#undef zz -#undef t -#ifdef __cplusplus -} -#endif - diff --git a/ext/f2c_blas/dcopy.c b/ext/f2c_blas/dcopy.c deleted file mode 100644 index fe65b56d0..000000000 --- a/ext/f2c_blas/dcopy.c +++ /dev/null @@ -1,79 +0,0 @@ -#include "blaswrap.h" -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dcopy_(integer *n, doublereal *dx, integer *incx, - doublereal *dy, integer *incy) -{ - /* System generated locals */ - integer i__1; - /* Local variables */ - static integer i__, m, ix, iy, mp1; -/* copies a vector, x, to a vector, y. - uses unrolled loops for increments equal to one. - jack dongarra, linpack, 3/11/78. - modified 12/3/93, array(1) declarations changed to array(*) - Parameter adjustments */ - --dy; - --dx; - /* Function Body */ - if (*n <= 0) { - return 0; - } - if (*incx == 1 && *incy == 1) { - goto L20; - } -/* code for unequal increments or equal increments - not equal to 1 */ - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dy[iy] = dx[ix]; - ix += *incx; - iy += *incy; -/* L10: */ - } - return 0; -/* code for both increments equal to 1 - clean-up loop */ -L20: - m = *n % 7; - if (m == 0) { - goto L40; - } - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dy[i__] = dx[i__]; -/* L30: */ - } - if (*n < 7) { - return 0; - } -L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 7) { - dy[i__] = dx[i__]; - dy[i__ + 1] = dx[i__ + 1]; - dy[i__ + 2] = dx[i__ + 2]; - dy[i__ + 3] = dx[i__ + 3]; - dy[i__ + 4] = dx[i__ + 4]; - dy[i__ + 5] = dx[i__ + 5]; - dy[i__ + 6] = dx[i__ + 6]; -/* L50: */ - } - return 0; -} /* dcopy_ */ -#ifdef __cplusplus -} -#endif - diff --git a/ext/f2c_blas/ddot.c b/ext/f2c_blas/ddot.c deleted file mode 100644 index 8ee33bd77..000000000 --- a/ext/f2c_blas/ddot.c +++ /dev/null @@ -1,82 +0,0 @@ -#include "blaswrap.h" -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, - integer *incy) -{ - /* System generated locals */ - integer i__1; - doublereal ret_val; - /* Local variables */ - static integer i__, m; - static doublereal dtemp; - static integer ix, iy, mp1; -/* forms the dot product of two vectors. - uses unrolled loops for increments equal to one. - jack dongarra, linpack, 3/11/78. - modified 12/3/93, array(1) declarations changed to array(*) - Parameter adjustments */ - --dy; - --dx; - /* Function Body */ - ret_val = 0.; - dtemp = 0.; - if (*n <= 0) { - return ret_val; - } - if (*incx == 1 && *incy == 1) { - goto L20; - } -/* code for unequal increments or equal increments - not equal to 1 */ - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp += dx[ix] * dy[iy]; - ix += *incx; - iy += *incy; -/* L10: */ - } - ret_val = dtemp; - return ret_val; -/* code for both increments equal to 1 - clean-up loop */ -L20: - m = *n % 5; - if (m == 0) { - goto L40; - } - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp += dx[i__] * dy[i__]; -/* L30: */ - } - if (*n < 5) { - goto L60; - } -L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 5) { - dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] + dx[ - i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] + dx[i__ + - 4] * dy[i__ + 4]; -/* L50: */ - } -L60: - ret_val = dtemp; - return ret_val; -} /* ddot_ */ -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_blas/dgbmv.c b/ext/f2c_blas/dgbmv.c deleted file mode 100644 index fb8c16c87..000000000 --- a/ext/f2c_blas/dgbmv.c +++ /dev/null @@ -1,307 +0,0 @@ -#include "blaswrap.h" -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgbmv_(char *trans, integer *m, integer *n, integer *kl, - integer *ku, doublereal *alpha, doublereal *a, integer *lda, - doublereal *x, integer *incx, doublereal *beta, doublereal *y, - integer *incy) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; - /* Local variables */ - static integer info; - static doublereal temp; - static integer lenx, leny, i__, j, k; - extern logical lsame_(char *, char *); - static integer ix, iy, jx, jy, kx, ky; - extern /* Subroutine */ int xerbla_(char *, integer *); - static integer kup1; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -/* Purpose - ======= - DGBMV performs one of the matrix-vector operations - y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, - where alpha and beta are scalars, x and y are vectors and A is an - m by n band matrix, with kl sub-diagonals and ku super-diagonals. - Parameters - ========== - TRANS - CHARACTER*1. - On entry, TRANS specifies the operation to be performed as - follows: - TRANS = 'N' or 'n' y := alpha*A*x + beta*y. - TRANS = 'T' or 't' y := alpha*A'*x + beta*y. - TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. - Unchanged on exit. - M - INTEGER. - On entry, M specifies the number of rows of the matrix A. - M must be at least zero. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the number of columns of the matrix A. - N must be at least zero. - Unchanged on exit. - KL - INTEGER. - On entry, KL specifies the number of sub-diagonals of the - matrix A. KL must satisfy 0 .le. KL. - Unchanged on exit. - KU - INTEGER. - On entry, KU specifies the number of super-diagonals of the - matrix A. KU must satisfy 0 .le. KU. - Unchanged on exit. - ALPHA - DOUBLE PRECISION. - On entry, ALPHA specifies the scalar alpha. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). - Before entry, the leading ( kl + ku + 1 ) by n part of the - array A must contain the matrix of coefficients, supplied - column by column, with the leading diagonal of the matrix in - row ( ku + 1 ) of the array, the first super-diagonal - starting at position 2 in row ku, the first sub-diagonal - starting at position 1 in row ( ku + 2 ), and so on. - Elements in the array A that do not correspond to elements - in the band matrix (such as the top left ku by ku triangle) - are not referenced. - The following program segment will transfer a band matrix - from conventional full matrix storage to band storage: - DO 20, J = 1, N - K = KU + 1 - J - DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) - A( K + I, J ) = matrix( I, J ) - 10 CONTINUE - 20 CONTINUE - Unchanged on exit. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. LDA must be at least - ( kl + ku + 1 ). - Unchanged on exit. - X - DOUBLE PRECISION array of DIMENSION at least - ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' - and at least - ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. - Before entry, the incremented array X must contain the - vector x. - Unchanged on exit. - INCX - INTEGER. - On entry, INCX specifies the increment for the elements of - X. INCX must not be zero. - Unchanged on exit. - BETA - DOUBLE PRECISION. - On entry, BETA specifies the scalar beta. When BETA is - supplied as zero then Y need not be set on input. - Unchanged on exit. - Y - DOUBLE PRECISION array of DIMENSION at least - ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' - and at least - ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. - Before entry, the incremented array Y must contain the - vector y. On exit, Y is overwritten by the updated vector y. - INCY - INTEGER. - On entry, INCY specifies the increment for the elements of - Y. INCY must not be zero. - Unchanged on exit. - Level 2 Blas routine. - -- Written on 22-October-1986. - Jack Dongarra, Argonne National Lab. - Jeremy Du Croz, Nag Central Office. - Sven Hammarling, Nag Central Office. - Richard Hanson, Sandia National Labs. - Test the input parameters. - Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --x; - --y; - /* Function Body */ - info = 0; - if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C") - ) { - info = 1; - } else if (*m < 0) { - info = 2; - } else if (*n < 0) { - info = 3; - } else if (*kl < 0) { - info = 4; - } else if (*ku < 0) { - info = 5; - } else if (*lda < *kl + *ku + 1) { - info = 8; - } else if (*incx == 0) { - info = 10; - } else if (*incy == 0) { - info = 13; - } - if (info != 0) { - xerbla_("DGBMV ", &info); - return 0; - } -/* Quick return if possible. */ - if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { - return 0; - } -/* Set LENX and LENY, the lengths of the vectors x and y, and set - up the start points in X and Y. */ - if (lsame_(trans, "N")) { - lenx = *n; - leny = *m; - } else { - lenx = *m; - leny = *n; - } - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (lenx - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (leny - 1) * *incy; - } -/* Start the operations. In this version the elements of A are - accessed sequentially with one pass through the band part of A. - First form y := beta*y. */ - if (*beta != 1.) { - if (*incy == 1) { - if (*beta == 0.) { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.; -/* L10: */ - } - } else { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.) { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.; - iy += *incy; -/* L30: */ - } - } else { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.) { - return 0; - } - kup1 = *ku + 1; - if (lsame_(trans, "N")) { -/* Form y := alpha*A*x + y. */ - jx = kx; - if (*incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - k = kup1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *ku; -/* Computing MIN */ - i__5 = *m, i__6 = j + *kl; - i__4 = min(i__5,i__6); - for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { - y[i__] += temp * a_ref(k + i__, j); -/* L50: */ - } - } - jx += *incx; -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - iy = ky; - k = kup1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *ku; -/* Computing MIN */ - i__5 = *m, i__6 = j + *kl; - i__3 = min(i__5,i__6); - for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { - y[iy] += temp * a_ref(k + i__, j); - iy += *incy; -/* L70: */ - } - } - jx += *incx; - if (j > *ku) { - ky += *incy; - } -/* L80: */ - } - } - } else { -/* Form y := alpha*A'*x + y. */ - jy = ky; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = 0.; - k = kup1 - j; -/* Computing MAX */ - i__3 = 1, i__4 = j - *ku; -/* Computing MIN */ - i__5 = *m, i__6 = j + *kl; - i__2 = min(i__5,i__6); - for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) { - temp += a_ref(k + i__, j) * x[i__]; -/* L90: */ - } - y[jy] += *alpha * temp; - jy += *incy; -/* L100: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = 0.; - ix = kx; - k = kup1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *ku; -/* Computing MIN */ - i__5 = *m, i__6 = j + *kl; - i__4 = min(i__5,i__6); - for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { - temp += a_ref(k + i__, j) * x[ix]; - ix += *incx; -/* L110: */ - } - y[jy] += *alpha * temp; - jy += *incy; - if (j > *ku) { - kx += *incx; - } -/* L120: */ - } - } - } - return 0; -/* End of DGBMV . */ -} /* dgbmv_ */ -#undef a_ref -#ifdef __cplusplus -} -#endif - diff --git a/ext/f2c_blas/dgemm.c b/ext/f2c_blas/dgemm.c deleted file mode 100644 index f7bc7cfa6..000000000 --- a/ext/f2c_blas/dgemm.c +++ /dev/null @@ -1,319 +0,0 @@ -#include "blaswrap.h" -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgemm_(char *transa, char *transb, integer *m, integer * - n, integer *k, doublereal *alpha, doublereal *a, integer *lda, - doublereal *b, integer *ldb, doublereal *beta, doublereal *c__, - integer *ldc) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3; - /* Local variables */ - static integer info; - static logical nota, notb; - static doublereal temp; - static integer i__, j, l, ncola; - extern logical lsame_(char *, char *); - static integer nrowa, nrowb; - extern /* Subroutine */ int xerbla_(char *, integer *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] -#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] -/* Purpose - ======= - DGEMM performs one of the matrix-matrix operations - C := alpha*op( A )*op( B ) + beta*C, - where op( X ) is one of - op( X ) = X or op( X ) = X', - alpha and beta are scalars, and A, B and C are matrices, with op( A ) - an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. - Parameters - ========== - TRANSA - CHARACTER*1. - On entry, TRANSA specifies the form of op( A ) to be used in - the matrix multiplication as follows: - TRANSA = 'N' or 'n', op( A ) = A. - TRANSA = 'T' or 't', op( A ) = A'. - TRANSA = 'C' or 'c', op( A ) = A'. - Unchanged on exit. - TRANSB - CHARACTER*1. - On entry, TRANSB specifies the form of op( B ) to be used in - the matrix multiplication as follows: - TRANSB = 'N' or 'n', op( B ) = B. - TRANSB = 'T' or 't', op( B ) = B'. - TRANSB = 'C' or 'c', op( B ) = B'. - Unchanged on exit. - M - INTEGER. - On entry, M specifies the number of rows of the matrix - op( A ) and of the matrix C. M must be at least zero. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the number of columns of the matrix - op( B ) and the number of columns of the matrix C. N must be - at least zero. - Unchanged on exit. - K - INTEGER. - On entry, K specifies the number of columns of the matrix - op( A ) and the number of rows of the matrix op( B ). K must - be at least zero. - Unchanged on exit. - ALPHA - DOUBLE PRECISION. - On entry, ALPHA specifies the scalar alpha. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is - k when TRANSA = 'N' or 'n', and is m otherwise. - Before entry with TRANSA = 'N' or 'n', the leading m by k - part of the array A must contain the matrix A, otherwise - the leading k by m part of the array A must contain the - matrix A. - Unchanged on exit. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. When TRANSA = 'N' or 'n' then - LDA must be at least max( 1, m ), otherwise LDA must be at - least max( 1, k ). - Unchanged on exit. - B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is - n when TRANSB = 'N' or 'n', and is k otherwise. - Before entry with TRANSB = 'N' or 'n', the leading k by n - part of the array B must contain the matrix B, otherwise - the leading n by k part of the array B must contain the - matrix B. - Unchanged on exit. - LDB - INTEGER. - On entry, LDB specifies the first dimension of B as declared - in the calling (sub) program. When TRANSB = 'N' or 'n' then - LDB must be at least max( 1, k ), otherwise LDB must be at - least max( 1, n ). - Unchanged on exit. - BETA - DOUBLE PRECISION. - On entry, BETA specifies the scalar beta. When BETA is - supplied as zero then C need not be set on input. - Unchanged on exit. - C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). - Before entry, the leading m by n part of the array C must - contain the matrix C, except when beta is zero, in which - case C need not be set on entry. - On exit, the array C is overwritten by the m by n matrix - ( alpha*op( A )*op( B ) + beta*C ). - LDC - INTEGER. - On entry, LDC specifies the first dimension of C as declared - in the calling (sub) program. LDC must be at least - max( 1, m ). - Unchanged on exit. - Level 3 Blas routine. - -- Written on 8-February-1989. - Jack Dongarra, Argonne National Laboratory. - Iain Duff, AERE Harwell. - Jeremy Du Croz, Numerical Algorithms Group Ltd. - Sven Hammarling, Numerical Algorithms Group Ltd. - Set NOTA and NOTB as true if A and B respectively are not - transposed and set NROWA, NCOLA and NROWB as the number of rows - and columns of A and the number of rows of B respectively. - Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - /* Function Body */ - nota = lsame_(transa, "N"); - notb = lsame_(transb, "N"); - if (nota) { - nrowa = *m; - ncola = *k; - } else { - nrowa = *k; - ncola = *m; - } - if (notb) { - nrowb = *k; - } else { - nrowb = *n; - } -/* Test the input parameters. */ - info = 0; - if (! nota && ! lsame_(transa, "C") && ! lsame_( - transa, "T")) { - info = 1; - } else if (! notb && ! lsame_(transb, "C") && ! - lsame_(transb, "T")) { - info = 2; - } else if (*m < 0) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*k < 0) { - info = 5; - } else if (*lda < max(1,nrowa)) { - info = 8; - } else if (*ldb < max(1,nrowb)) { - info = 10; - } else if (*ldc < max(1,*m)) { - info = 13; - } - if (info != 0) { - xerbla_("DGEMM ", &info); - return 0; - } -/* Quick return if possible. */ - if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { - return 0; - } -/* And if alpha.eq.zero. */ - if (*alpha == 0.) { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = 0.; -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = *beta * c___ref(i__, j); -/* L30: */ - } -/* L40: */ - } - } - return 0; - } -/* Start the operations. */ - if (notb) { - if (nota) { -/* Form C := alpha*A*B + beta*C. */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = 0.; -/* L50: */ - } - } else if (*beta != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = *beta * c___ref(i__, j); -/* L60: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (b_ref(l, j) != 0.) { - temp = *alpha * b_ref(l, j); - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - c___ref(i__, j) = c___ref(i__, j) + temp * a_ref( - i__, l); -/* L70: */ - } - } -/* L80: */ - } -/* L90: */ - } - } else { -/* Form C := alpha*A'*B + beta*C */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a_ref(l, i__) * b_ref(l, j); -/* L100: */ - } - if (*beta == 0.) { - c___ref(i__, j) = *alpha * temp; - } else { - c___ref(i__, j) = *alpha * temp + *beta * c___ref(i__, - j); - } -/* L110: */ - } -/* L120: */ - } - } - } else { - if (nota) { -/* Form C := alpha*A*B' + beta*C */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = 0.; -/* L130: */ - } - } else if (*beta != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = *beta * c___ref(i__, j); -/* L140: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (b_ref(j, l) != 0.) { - temp = *alpha * b_ref(j, l); - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - c___ref(i__, j) = c___ref(i__, j) + temp * a_ref( - i__, l); -/* L150: */ - } - } -/* L160: */ - } -/* L170: */ - } - } else { -/* Form C := alpha*A'*B' + beta*C */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a_ref(l, i__) * b_ref(j, l); -/* L180: */ - } - if (*beta == 0.) { - c___ref(i__, j) = *alpha * temp; - } else { - c___ref(i__, j) = *alpha * temp + *beta * c___ref(i__, - j); - } -/* L190: */ - } -/* L200: */ - } - } - } - return 0; -/* End of DGEMM . */ -} /* dgemm_ */ -#undef c___ref -#undef b_ref -#undef a_ref -#ifdef __cplusplus -} -#endif - diff --git a/ext/f2c_blas/dgemv.c b/ext/f2c_blas/dgemv.c deleted file mode 100644 index 91686250e..000000000 --- a/ext/f2c_blas/dgemv.c +++ /dev/null @@ -1,251 +0,0 @@ -#include "blaswrap.h" -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgemv_(char *trans, integer *m, integer *n, doublereal * - alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, - doublereal *beta, doublereal *y, integer *incy) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - /* Local variables */ - static integer info; - static doublereal temp; - static integer lenx, leny, i__, j; - extern logical lsame_(char *, char *); - static integer ix, iy, jx, jy, kx, ky; - extern /* Subroutine */ int xerbla_(char *, integer *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -/* Purpose - ======= - DGEMV performs one of the matrix-vector operations - y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, - where alpha and beta are scalars, x and y are vectors and A is an - m by n matrix. - Parameters - ========== - TRANS - CHARACTER*1. - On entry, TRANS specifies the operation to be performed as - follows: - TRANS = 'N' or 'n' y := alpha*A*x + beta*y. - TRANS = 'T' or 't' y := alpha*A'*x + beta*y. - TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. - Unchanged on exit. - M - INTEGER. - On entry, M specifies the number of rows of the matrix A. - M must be at least zero. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the number of columns of the matrix A. - N must be at least zero. - Unchanged on exit. - ALPHA - DOUBLE PRECISION. - On entry, ALPHA specifies the scalar alpha. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). - Before entry, the leading m by n part of the array A must - contain the matrix of coefficients. - Unchanged on exit. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. LDA must be at least - max( 1, m ). - Unchanged on exit. - X - DOUBLE PRECISION array of DIMENSION at least - ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' - and at least - ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. - Before entry, the incremented array X must contain the - vector x. - Unchanged on exit. - INCX - INTEGER. - On entry, INCX specifies the increment for the elements of - X. INCX must not be zero. - Unchanged on exit. - BETA - DOUBLE PRECISION. - On entry, BETA specifies the scalar beta. When BETA is - supplied as zero then Y need not be set on input. - Unchanged on exit. - Y - DOUBLE PRECISION array of DIMENSION at least - ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' - and at least - ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. - Before entry with BETA non-zero, the incremented array Y - must contain the vector y. On exit, Y is overwritten by the - updated vector y. - INCY - INTEGER. - On entry, INCY specifies the increment for the elements of - Y. INCY must not be zero. - Unchanged on exit. - Level 2 Blas routine. - -- Written on 22-October-1986. - Jack Dongarra, Argonne National Lab. - Jeremy Du Croz, Nag Central Office. - Sven Hammarling, Nag Central Office. - Richard Hanson, Sandia National Labs. - Test the input parameters. - Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --x; - --y; - /* Function Body */ - info = 0; - if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C") - ) { - info = 1; - } else if (*m < 0) { - info = 2; - } else if (*n < 0) { - info = 3; - } else if (*lda < max(1,*m)) { - info = 6; - } else if (*incx == 0) { - info = 8; - } else if (*incy == 0) { - info = 11; - } - if (info != 0) { - xerbla_("DGEMV ", &info); - return 0; - } -/* Quick return if possible. */ - if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { - return 0; - } -/* Set LENX and LENY, the lengths of the vectors x and y, and set - up the start points in X and Y. */ - if (lsame_(trans, "N")) { - lenx = *n; - leny = *m; - } else { - lenx = *m; - leny = *n; - } - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (lenx - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (leny - 1) * *incy; - } -/* Start the operations. In this version the elements of A are - accessed sequentially with one pass through A. - First form y := beta*y. */ - if (*beta != 1.) { - if (*incy == 1) { - if (*beta == 0.) { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.; -/* L10: */ - } - } else { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.) { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.; - iy += *incy; -/* L30: */ - } - } else { - i__1 = leny; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.) { - return 0; - } - if (lsame_(trans, "N")) { -/* Form y := alpha*A*x + y. */ - jx = kx; - if (*incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - y[i__] += temp * a_ref(i__, j); -/* L50: */ - } - } - jx += *incx; -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - iy = ky; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - y[iy] += temp * a_ref(i__, j); - iy += *incy; -/* L70: */ - } - } - jx += *incx; -/* L80: */ - } - } - } else { -/* Form y := alpha*A'*x + y. */ - jy = ky; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = 0.; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp += a_ref(i__, j) * x[i__]; -/* L90: */ - } - y[jy] += *alpha * temp; - jy += *incy; -/* L100: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = 0.; - ix = kx; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp += a_ref(i__, j) * x[ix]; - ix += *incx; -/* L110: */ - } - y[jy] += *alpha * temp; - jy += *incy; -/* L120: */ - } - } - } - return 0; -/* End of DGEMV . */ -} /* dgemv_ */ -#undef a_ref -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_blas/dger.c b/ext/f2c_blas/dger.c deleted file mode 100644 index c4819a498..000000000 --- a/ext/f2c_blas/dger.c +++ /dev/null @@ -1,149 +0,0 @@ -#include "blaswrap.h" -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dger_(integer *m, integer *n, doublereal *alpha, - doublereal *x, integer *incx, doublereal *y, integer *incy, - doublereal *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - /* Local variables */ - static integer info; - static doublereal temp; - static integer i__, j, ix, jy, kx; - extern /* Subroutine */ int xerbla_(char *, integer *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -/* Purpose - ======= - DGER performs the rank 1 operation - A := alpha*x*y' + A, - where alpha is a scalar, x is an m element vector, y is an n element - vector and A is an m by n matrix. - Parameters - ========== - M - INTEGER. - On entry, M specifies the number of rows of the matrix A. - M must be at least zero. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the number of columns of the matrix A. - N must be at least zero. - Unchanged on exit. - ALPHA - DOUBLE PRECISION. - On entry, ALPHA specifies the scalar alpha. - Unchanged on exit. - X - DOUBLE PRECISION array of dimension at least - ( 1 + ( m - 1 )*abs( INCX ) ). - Before entry, the incremented array X must contain the m - element vector x. - Unchanged on exit. - INCX - INTEGER. - On entry, INCX specifies the increment for the elements of - X. INCX must not be zero. - Unchanged on exit. - Y - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCY ) ). - Before entry, the incremented array Y must contain the n - element vector y. - Unchanged on exit. - INCY - INTEGER. - On entry, INCY specifies the increment for the elements of - Y. INCY must not be zero. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). - Before entry, the leading m by n part of the array A must - contain the matrix of coefficients. On exit, A is - overwritten by the updated matrix. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. LDA must be at least - max( 1, m ). - Unchanged on exit. - Level 2 Blas routine. - -- Written on 22-October-1986. - Jack Dongarra, Argonne National Lab. - Jeremy Du Croz, Nag Central Office. - Sven Hammarling, Nag Central Office. - Richard Hanson, Sandia National Labs. - Test the input parameters. - Parameter adjustments */ - --x; - --y; - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - /* Function Body */ - info = 0; - if (*m < 0) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 5; - } else if (*incy == 0) { - info = 7; - } else if (*lda < max(1,*m)) { - info = 9; - } - if (info != 0) { - xerbla_("DGER ", &info); - return 0; - } -/* Quick return if possible. */ - if (*m == 0 || *n == 0 || *alpha == 0.) { - return 0; - } -/* Start the operations. In this version the elements of A are - accessed sequentially with one pass through A. */ - if (*incy > 0) { - jy = 1; - } else { - jy = 1 - (*n - 1) * *incy; - } - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (y[jy] != 0.) { - temp = *alpha * y[jy]; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - a_ref(i__, j) = a_ref(i__, j) + x[i__] * temp; -/* L10: */ - } - } - jy += *incy; -/* L20: */ - } - } else { - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*m - 1) * *incx; - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (y[jy] != 0.) { - temp = *alpha * y[jy]; - ix = kx; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - a_ref(i__, j) = a_ref(i__, j) + x[ix] * temp; - ix += *incx; -/* L30: */ - } - } - jy += *incy; -/* L40: */ - } - } - return 0; -/* End of DGER . */ -} /* dger_ */ -#undef a_ref -#ifdef __cplusplus -} -#endif - diff --git a/ext/f2c_blas/dnrm2.c b/ext/f2c_blas/dnrm2.c deleted file mode 100644 index 17156777b..000000000 --- a/ext/f2c_blas/dnrm2.c +++ /dev/null @@ -1,68 +0,0 @@ -#include "blaswrap.h" -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -doublereal dnrm2_(integer *n, doublereal *x, integer *incx) -{ -/* The following loop is equivalent to this call to the LAPACK - auxiliary routine: - CALL DLASSQ( N, X, INCX, SCALE, SSQ ) */ - /* System generated locals */ - integer i__1, i__2; - doublereal ret_val, d__1; - /* Builtin functions */ - double sqrt(doublereal); - /* Local variables */ - static doublereal norm, scale, absxi; - static integer ix; - static doublereal ssq; -/* DNRM2 returns the euclidean norm of a vector via the function - name, so that - DNRM2 := sqrt( x'*x ) - -- This version written on 25-October-1982. - Modified on 14-October-1993 to inline the call to DLASSQ. - Sven Hammarling, Nag Ltd. - Parameter adjustments */ - --x; - /* Function Body */ - if (*n < 1 || *incx < 1) { - norm = 0.; - } else if (*n == 1) { - norm = abs(x[1]); - } else { - scale = 0.; - ssq = 1.; - - - i__1 = (*n - 1) * *incx + 1; - i__2 = *incx; - for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { - if (x[ix] != 0.) { - absxi = (d__1 = x[ix], abs(d__1)); - if (scale < absxi) { -/* Computing 2nd power */ - d__1 = scale / absxi; - ssq = ssq * (d__1 * d__1) + 1.; - scale = absxi; - } else { -/* Computing 2nd power */ - d__1 = absxi / scale; - ssq += d__1 * d__1; - } - } -/* L10: */ - } - norm = scale * sqrt(ssq); - } - - ret_val = norm; - return ret_val; - -/* End of DNRM2. */ - -} /* dnrm2_ */ -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_blas/drot.c b/ext/f2c_blas/drot.c deleted file mode 100644 index 2c6cf7f0a..000000000 --- a/ext/f2c_blas/drot.c +++ /dev/null @@ -1,62 +0,0 @@ -#include "blaswrap.h" -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int drot_(integer *n, doublereal *dx, integer *incx, - doublereal *dy, integer *incy, doublereal *c__, doublereal *s) -{ - /* System generated locals */ - integer i__1; - /* Local variables */ - static integer i__; - static doublereal dtemp; - static integer ix, iy; -/* applies a plane rotation. - jack dongarra, linpack, 3/11/78. - modified 12/3/93, array(1) declarations changed to array(*) - Parameter adjustments */ - --dy; - --dx; - /* Function Body */ - if (*n <= 0) { - return 0; - } - if (*incx == 1 && *incy == 1) { - goto L20; - } -/* code for unequal increments or equal increments not equal - to 1 */ - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp = *c__ * dx[ix] + *s * dy[iy]; - dy[iy] = *c__ * dy[iy] - *s * dx[ix]; - dx[ix] = dtemp; - ix += *incx; - iy += *incy; -/* L10: */ - } - return 0; -/* code for both increments equal to 1 */ -L20: - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp = *c__ * dx[i__] + *s * dy[i__]; - dy[i__] = *c__ * dy[i__] - *s * dx[i__]; - dx[i__] = dtemp; -/* L30: */ - } - return 0; -} /* drot_ */ -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_blas/drotg.c b/ext/f2c_blas/drotg.c deleted file mode 100644 index 86a7eb652..000000000 --- a/ext/f2c_blas/drotg.c +++ /dev/null @@ -1,57 +0,0 @@ -#include "blaswrap.h" -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int drotg_(doublereal *da, doublereal *db, doublereal *c__, - doublereal *s) -{ - /* Table of constant values */ - static doublereal c_b4 = 1.; - - /* System generated locals */ - doublereal d__1, d__2; - /* Builtin functions */ - double sqrt(doublereal), d_sign(doublereal *, doublereal *); - /* Local variables */ - static doublereal r__, scale, z__, roe; -/* construct givens plane rotation. - jack dongarra, linpack, 3/11/78. */ - roe = *db; - if (abs(*da) > abs(*db)) { - roe = *da; - } - scale = abs(*da) + abs(*db); - if (scale != 0.) { - goto L10; - } - *c__ = 1.; - *s = 0.; - r__ = 0.; - z__ = 0.; - goto L20; -L10: -/* Computing 2nd power */ - d__1 = *da / scale; -/* Computing 2nd power */ - d__2 = *db / scale; - r__ = scale * sqrt(d__1 * d__1 + d__2 * d__2); - r__ = d_sign(&c_b4, &roe) * r__; - *c__ = *da / r__; - *s = *db / r__; - z__ = 1.; - if (abs(*da) > abs(*db)) { - z__ = *s; - } - if (abs(*db) >= abs(*da) && *c__ != 0.) { - z__ = 1. / *c__; - } -L20: - *da = r__; - *db = z__; - return 0; -} /* drotg_ */ -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_blas/drotm.c b/ext/f2c_blas/drotm.c deleted file mode 100644 index fd6c9127d..000000000 --- a/ext/f2c_blas/drotm.c +++ /dev/null @@ -1,183 +0,0 @@ -/* drotm.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int drotm_(integer *n, doublereal *dx, integer *incx, - doublereal *dy, integer *incy, doublereal *dparam) -{ - /* Initialized data */ - - static doublereal zero = 0.; - static doublereal two = 2.; - - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - static integer i__; - static doublereal w, z__; - static integer kx, ky; - static doublereal dh11, dh12, dh22, dh21, dflag; - static integer nsteps; - - -/* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */ - -/* (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN */ -/* (DY**T) */ - -/* DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */ -/* LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. */ -/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ - -/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */ - -/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */ -/* H=( ) ( ) ( ) ( ) */ -/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */ -/* SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. */ - - /* Parameter adjustments */ - --dparam; - --dy; - --dx; - - /* Function Body */ - - dflag = dparam[1]; - if (*n <= 0 || dflag + two == zero) { - goto L140; - } - if (! (*incx == *incy && *incx > 0)) { - goto L70; - } - - nsteps = *n * *incx; - if (dflag < 0.) { - goto L50; - } else if (dflag == 0) { - goto L10; - } else { - goto L30; - } -L10: - dh12 = dparam[4]; - dh21 = dparam[3]; - i__1 = nsteps; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - w = dx[i__]; - z__ = dy[i__]; - dx[i__] = w + z__ * dh12; - dy[i__] = w * dh21 + z__; -/* L20: */ - } - goto L140; -L30: - dh11 = dparam[2]; - dh22 = dparam[5]; - i__2 = nsteps; - i__1 = *incx; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { - w = dx[i__]; - z__ = dy[i__]; - dx[i__] = w * dh11 + z__; - dy[i__] = -w + dh22 * z__; -/* L40: */ - } - goto L140; -L50: - dh11 = dparam[2]; - dh12 = dparam[4]; - dh21 = dparam[3]; - dh22 = dparam[5]; - i__1 = nsteps; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - w = dx[i__]; - z__ = dy[i__]; - dx[i__] = w * dh11 + z__ * dh12; - dy[i__] = w * dh21 + z__ * dh22; -/* L60: */ - } - goto L140; -L70: - kx = 1; - ky = 1; - if (*incx < 0) { - kx = (1 - *n) * *incx + 1; - } - if (*incy < 0) { - ky = (1 - *n) * *incy + 1; - } - - if (dflag < 0.) { - goto L120; - } else if (dflag == 0) { - goto L80; - } else { - goto L100; - } -L80: - dh12 = dparam[4]; - dh21 = dparam[3]; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - w = dx[kx]; - z__ = dy[ky]; - dx[kx] = w + z__ * dh12; - dy[ky] = w * dh21 + z__; - kx += *incx; - ky += *incy; -/* L90: */ - } - goto L140; -L100: - dh11 = dparam[2]; - dh22 = dparam[5]; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - w = dx[kx]; - z__ = dy[ky]; - dx[kx] = w * dh11 + z__; - dy[ky] = -w + dh22 * z__; - kx += *incx; - ky += *incy; -/* L110: */ - } - goto L140; -L120: - dh11 = dparam[2]; - dh12 = dparam[4]; - dh21 = dparam[3]; - dh22 = dparam[5]; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - w = dx[kx]; - z__ = dy[ky]; - dx[kx] = w * dh11 + z__ * dh12; - dy[ky] = w * dh21 + z__ * dh22; - kx += *incx; - ky += *incy; -/* L130: */ - } -L140: - return 0; -} /* drotm_ */ - -#ifdef __cplusplus - } -#endif diff --git a/ext/f2c_blas/drotmg.c b/ext/f2c_blas/drotmg.c deleted file mode 100644 index 19f0d758e..000000000 --- a/ext/f2c_blas/drotmg.c +++ /dev/null @@ -1,265 +0,0 @@ -/* drotmg.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int drotmg_(doublereal *dd1, doublereal *dd2, doublereal * - dx1, doublereal *dy1, doublereal *dparam) -{ - /* Initialized data */ - - static doublereal zero = 0.; - static doublereal one = 1.; - static doublereal two = 2.; - static doublereal gam = 4096.; - static doublereal gamsq = 16777216.; - static doublereal rgamsq = 5.9604645e-8; - - /* Format strings */ - static char fmt_120[] = ""; - static char fmt_150[] = ""; - static char fmt_180[] = ""; - static char fmt_210[] = ""; - - /* System generated locals */ - doublereal d__1; - - /* Local variables */ - static doublereal du, dp1, dp2, dq2, dq1, dh11, dh21, dh12, dh22; - static integer igo; - static doublereal dflag, dtemp; - - /* Assigned format variables */ - static char *igo_fmt; - - -/* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */ -/* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)* */ -/* DY2)**T. */ -/* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */ - -/* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0 */ - -/* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0) */ -/* H=( ) ( ) ( ) ( ) */ -/* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0). */ -/* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 */ -/* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE */ -/* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) */ - -/* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */ -/* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */ -/* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */ - - - /* Parameter adjustments */ - --dparam; - - /* Function Body */ - if (! (*dd1 < zero)) { - goto L10; - } -/* GO ZERO-H-D-AND-DX1.. */ - goto L60; -L10: -/* CASE-DD1-NONNEGATIVE */ - dp2 = *dd2 * *dy1; - if (! (dp2 == zero)) { - goto L20; - } - dflag = -two; - goto L260; -/* REGULAR-CASE.. */ -L20: - dp1 = *dd1 * *dx1; - dq2 = dp2 * *dy1; - dq1 = dp1 * *dx1; - - if (! (abs(dq1) > abs(dq2))) { - goto L40; - } - dh21 = -(*dy1) / *dx1; - dh12 = dp2 / dp1; - - du = one - dh12 * dh21; - - if (! (du <= zero)) { - goto L30; - } -/* GO ZERO-H-D-AND-DX1.. */ - goto L60; -L30: - dflag = zero; - *dd1 /= du; - *dd2 /= du; - *dx1 *= du; -/* GO SCALE-CHECK.. */ - goto L100; -L40: - if (! (dq2 < zero)) { - goto L50; - } -/* GO ZERO-H-D-AND-DX1.. */ - goto L60; -L50: - dflag = one; - dh11 = dp1 / dp2; - dh22 = *dx1 / *dy1; - du = one + dh11 * dh22; - dtemp = *dd2 / du; - *dd2 = *dd1 / du; - *dd1 = dtemp; - *dx1 = *dy1 * du; -/* GO SCALE-CHECK */ - goto L100; -/* PROCEDURE..ZERO-H-D-AND-DX1.. */ -L60: - dflag = -one; - dh11 = zero; - dh12 = zero; - dh21 = zero; - dh22 = zero; - - *dd1 = zero; - *dd2 = zero; - *dx1 = zero; -/* RETURN.. */ - goto L220; -/* PROCEDURE..FIX-H.. */ -L70: - if (! (dflag >= zero)) { - goto L90; - } - - if (! (dflag == zero)) { - goto L80; - } - dh11 = one; - dh22 = one; - dflag = -one; - goto L90; -L80: - dh21 = -one; - dh12 = one; - dflag = -one; -L90: - switch (igo) { - case 0: goto L120; - case 1: goto L150; - case 2: goto L180; - case 3: goto L210; - } -/* PROCEDURE..SCALE-CHECK */ -L100: -L110: - if (! (*dd1 <= rgamsq)) { - goto L130; - } - if (*dd1 == zero) { - goto L160; - } - igo = 0; - igo_fmt = fmt_120; -/* FIX-H.. */ - goto L70; -L120: -/* Computing 2nd power */ - d__1 = gam; - *dd1 *= d__1 * d__1; - *dx1 /= gam; - dh11 /= gam; - dh12 /= gam; - goto L110; -L130: -L140: - if (! (*dd1 >= gamsq)) { - goto L160; - } - igo = 1; - igo_fmt = fmt_150; -/* FIX-H.. */ - goto L70; -L150: -/* Computing 2nd power */ - d__1 = gam; - *dd1 /= d__1 * d__1; - *dx1 *= gam; - dh11 *= gam; - dh12 *= gam; - goto L140; -L160: -L170: - if (! (abs(*dd2) <= rgamsq)) { - goto L190; - } - if (*dd2 == zero) { - goto L220; - } - igo = 2; - igo_fmt = fmt_180; -/* FIX-H.. */ - goto L70; -L180: -/* Computing 2nd power */ - d__1 = gam; - *dd2 *= d__1 * d__1; - dh21 /= gam; - dh22 /= gam; - goto L170; -L190: -L200: - if (! (abs(*dd2) >= gamsq)) { - goto L220; - } - igo = 3; - igo_fmt = fmt_210; -/* FIX-H.. */ - goto L70; -L210: -/* Computing 2nd power */ - d__1 = gam; - *dd2 /= d__1 * d__1; - dh21 *= gam; - dh22 *= gam; - goto L200; -L220: - if (dflag < 0.) { - goto L250; - } else if (dflag == 0) { - goto L230; - } else { - goto L240; - } -L230: - dparam[3] = dh21; - dparam[4] = dh12; - goto L260; -L240: - dparam[2] = dh11; - dparam[5] = dh22; - goto L260; -L250: - dparam[2] = dh11; - dparam[3] = dh21; - dparam[4] = dh12; - dparam[5] = dh22; -L260: - dparam[1] = dflag; - return 0; -} /* drotmg_ */ - -#ifdef __cplusplus - } -#endif diff --git a/ext/f2c_blas/dsbmv.c b/ext/f2c_blas/dsbmv.c deleted file mode 100644 index bf4a049c0..000000000 --- a/ext/f2c_blas/dsbmv.c +++ /dev/null @@ -1,299 +0,0 @@ -#include "blaswrap.h" -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dsbmv_(char *uplo, integer *n, integer *k, doublereal * - alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, - doublereal *beta, doublereal *y, integer *incy) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - /* Local variables */ - static integer info; - static doublereal temp1, temp2; - static integer i__, j, l; - extern logical lsame_(char *, char *); - static integer kplus1, ix, iy, jx, jy, kx, ky; - extern /* Subroutine */ int xerbla_(char *, integer *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -/* Purpose - ======= - DSBMV performs the matrix-vector operation - y := alpha*A*x + beta*y, - where alpha and beta are scalars, x and y are n element vectors and - A is an n by n symmetric band matrix, with k super-diagonals. - Parameters - ========== - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the upper or lower - triangular part of the band matrix A is being supplied as - follows: - UPLO = 'U' or 'u' The upper triangular part of A is - being supplied. - UPLO = 'L' or 'l' The lower triangular part of A is - being supplied. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the order of the matrix A. - N must be at least zero. - Unchanged on exit. - K - INTEGER. - On entry, K specifies the number of super-diagonals of the - matrix A. K must satisfy 0 .le. K. - Unchanged on exit. - ALPHA - DOUBLE PRECISION. - On entry, ALPHA specifies the scalar alpha. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). - Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) - by n part of the array A must contain the upper triangular - band part of the symmetric matrix, supplied column by - column, with the leading diagonal of the matrix in row - ( k + 1 ) of the array, the first super-diagonal starting at - position 2 in row k, and so on. The top left k by k triangle - of the array A is not referenced. - The following program segment will transfer the upper - triangular part of a symmetric band matrix from conventional - full matrix storage to band storage: - DO 20, J = 1, N - M = K + 1 - J - DO 10, I = MAX( 1, J - K ), J - A( M + I, J ) = matrix( I, J ) - 10 CONTINUE - 20 CONTINUE - Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) - by n part of the array A must contain the lower triangular - band part of the symmetric matrix, supplied column by - column, with the leading diagonal of the matrix in row 1 of - the array, the first sub-diagonal starting at position 1 in - row 2, and so on. The bottom right k by k triangle of the - array A is not referenced. - The following program segment will transfer the lower - triangular part of a symmetric band matrix from conventional - full matrix storage to band storage: - DO 20, J = 1, N - M = 1 - J - DO 10, I = J, MIN( N, J + K ) - A( M + I, J ) = matrix( I, J ) - 10 CONTINUE - 20 CONTINUE - Unchanged on exit. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. LDA must be at least - ( k + 1 ). - Unchanged on exit. - X - DOUBLE PRECISION array of DIMENSION at least - ( 1 + ( n - 1 )*abs( INCX ) ). - Before entry, the incremented array X must contain the - vector x. - Unchanged on exit. - INCX - INTEGER. - On entry, INCX specifies the increment for the elements of - X. INCX must not be zero. - Unchanged on exit. - BETA - DOUBLE PRECISION. - On entry, BETA specifies the scalar beta. - Unchanged on exit. - Y - DOUBLE PRECISION array of DIMENSION at least - ( 1 + ( n - 1 )*abs( INCY ) ). - Before entry, the incremented array Y must contain the - vector y. On exit, Y is overwritten by the updated vector y. - INCY - INTEGER. - On entry, INCY specifies the increment for the elements of - Y. INCY must not be zero. - Unchanged on exit. - Level 2 Blas routine. - -- Written on 22-October-1986. - Jack Dongarra, Argonne National Lab. - Jeremy Du Croz, Nag Central Office. - Sven Hammarling, Nag Central Office. - Richard Hanson, Sandia National Labs. - Test the input parameters. - Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --x; - --y; - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*k < 0) { - info = 3; - } else if (*lda < *k + 1) { - info = 6; - } else if (*incx == 0) { - info = 8; - } else if (*incy == 0) { - info = 11; - } - if (info != 0) { - xerbla_("DSBMV ", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0 || *alpha == 0. && *beta == 1.) { - return 0; - } -/* Set up the start points in X and Y. */ - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } -/* Start the operations. In this version the elements of the array A - are accessed sequentially with one pass through A. - First form y := beta*y. */ - if (*beta != 1.) { - if (*incy == 1) { - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.; -/* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.; - iy += *incy; -/* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.) { - return 0; - } - if (lsame_(uplo, "U")) { -/* Form y when upper triangle of A is stored. */ - kplus1 = *k + 1; - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - l = kplus1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__4 = j - 1; - for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { - y[i__] += temp1 * a_ref(l + i__, j); - temp2 += a_ref(l + i__, j) * x[i__]; -/* L50: */ - } - y[j] = y[j] + temp1 * a_ref(kplus1, j) + *alpha * temp2; -/* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - ix = kx; - iy = ky; - l = kplus1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *k; - i__3 = j - 1; - for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { - y[iy] += temp1 * a_ref(l + i__, j); - temp2 += a_ref(l + i__, j) * x[ix]; - ix += *incx; - iy += *incy; -/* L70: */ - } - y[jy] = y[jy] + temp1 * a_ref(kplus1, j) + *alpha * temp2; - jx += *incx; - jy += *incy; - if (j > *k) { - kx += *incx; - ky += *incy; - } -/* L80: */ - } - } - } else { -/* Form y when lower triangle of A is stored. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - y[j] += temp1 * a_ref(1, j); - l = 1 - j; -/* Computing MIN */ - i__4 = *n, i__2 = j + *k; - i__3 = min(i__4,i__2); - for (i__ = j + 1; i__ <= i__3; ++i__) { - y[i__] += temp1 * a_ref(l + i__, j); - temp2 += a_ref(l + i__, j) * x[i__]; -/* L90: */ - } - y[j] += *alpha * temp2; -/* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - y[jy] += temp1 * a_ref(1, j); - l = 1 - j; - ix = jx; - iy = jy; -/* Computing MIN */ - i__4 = *n, i__2 = j + *k; - i__3 = min(i__4,i__2); - for (i__ = j + 1; i__ <= i__3; ++i__) { - ix += *incx; - iy += *incy; - y[iy] += temp1 * a_ref(l + i__, j); - temp2 += a_ref(l + i__, j) * x[ix]; -/* L110: */ - } - y[jy] += *alpha * temp2; - jx += *incx; - jy += *incy; -/* L120: */ - } - } - } - return 0; -/* End of DSBMV . */ -} /* dsbmv_ */ -#undef a_ref -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_blas/dscal.c b/ext/f2c_blas/dscal.c deleted file mode 100644 index e0e6ffb9c..000000000 --- a/ext/f2c_blas/dscal.c +++ /dev/null @@ -1,62 +0,0 @@ -#include "blaswrap.h" -#include "f2c.h" - -/* Subroutine */ int dscal_(integer *n, doublereal *da, doublereal *dx, - integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - /* Local variables */ - static integer i__, m, nincx, mp1; -/* scales a vector by a constant. - uses unrolled loops for increment equal to one. - jack dongarra, linpack, 3/11/78. - modified 3/93 to return if incx .le. 0. - modified 12/3/93, array(1) declarations changed to array(*) - Parameter adjustments */ - --dx; - /* Function Body */ - if (*n <= 0 || *incx <= 0) { - return 0; - } - if (*incx == 1) { - goto L20; - } -/* code for increment not equal to 1 */ - nincx = *n * *incx; - i__1 = nincx; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - dx[i__] = *da * dx[i__]; -/* L10: */ - } - return 0; -/* code for increment equal to 1 - clean-up loop */ -L20: - m = *n % 5; - if (m == 0) { - goto L40; - } - i__2 = m; - for (i__ = 1; i__ <= i__2; ++i__) { - dx[i__] = *da * dx[i__]; -/* L30: */ - } - if (*n < 5) { - return 0; - } -L40: - mp1 = m + 1; - i__2 = *n; - for (i__ = mp1; i__ <= i__2; i__ += 5) { - dx[i__] = *da * dx[i__]; - dx[i__ + 1] = *da * dx[i__ + 1]; - dx[i__ + 2] = *da * dx[i__ + 2]; - dx[i__ + 3] = *da * dx[i__ + 3]; - dx[i__ + 4] = *da * dx[i__ + 4]; -/* L50: */ - } - return 0; -} /* dscal_ */ - diff --git a/ext/f2c_blas/dsdot.c b/ext/f2c_blas/dsdot.c deleted file mode 100644 index 1ad7b27ea..000000000 --- a/ext/f2c_blas/dsdot.c +++ /dev/null @@ -1,122 +0,0 @@ -/* dsdot.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -/* DECK DSDOT */ -doublereal dsdot_(integer *n, real *sx, integer *incx, real *sy, integer * - incy) -{ - /* System generated locals */ - integer i__1, i__2; - doublereal ret_val; - - /* Local variables */ - static integer i__, ns, kx, ky; - -/* ***BEGIN PROLOGUE DSDOT */ -/* ***PURPOSE Compute the inner product of two vectors with extended */ -/* precision accumulation and result. */ -/* ***LIBRARY SLATEC (BLAS) */ -/* ***CATEGORY D1A4 */ -/* ***TYPE DOUBLE PRECISION (DSDOT-D, DCDOT-C) */ -/* ***KEYWORDS BLAS, COMPLEX VECTORS, DOT PRODUCT, INNER PRODUCT, */ -/* LINEAR ALGEBRA, VECTOR */ -/* ***AUTHOR Lawson, C. L., (JPL) */ -/* Hanson, R. J., (SNLA) */ -/* Kincaid, D. R., (U. of Texas) */ -/* Krogh, F. T., (JPL) */ -/* ***DESCRIPTION */ - -/* B L A S Subprogram */ -/* Description of Parameters */ - -/* --Input-- */ -/* N number of elements in input vector(s) */ -/* SX single precision vector with N elements */ -/* INCX storage spacing between elements of SX */ -/* SY single precision vector with N elements */ -/* INCY storage spacing between elements of SY */ - -/* --Output-- */ -/* DSDOT double precision dot product (zero if N.LE.0) */ - -/* Returns D.P. dot product accumulated in D.P., for S.P. SX and SY */ -/* DSDOT = sum for I = 0 to N-1 of SX(LX+I*INCX) * SY(LY+I*INCY), */ -/* where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is */ -/* defined in a similar way using INCY. */ - -/* ***REFERENCES C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. */ -/* Krogh, Basic linear algebra subprograms for Fortran */ -/* usage, Algorithm No. 539, Transactions on Mathematical */ -/* Software 5, 3 (September 1979), pp. 308-323. */ -/* ***ROUTINES CALLED (NONE) */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 791001 DATE WRITTEN */ -/* 890831 Modified array declarations. (WRB) */ -/* 890831 REVISION DATE from Version 3.2 */ -/* 891214 Prologue converted to Version 4.0 format. (BAB) */ -/* 920310 Corrected definition of LX in DESCRIPTION. (WRB) */ -/* 920501 Reformatted the REFERENCES section. (WRB) */ -/* ***END PROLOGUE DSDOT */ -/* ***FIRST EXECUTABLE STATEMENT DSDOT */ - /* Parameter adjustments */ - --sy; - --sx; - - /* Function Body */ - ret_val = 0.; - if (*n <= 0) { - return ret_val; - } - if (*incx == *incy && *incx > 0) { - goto L20; - } - -/* Code for unequal or nonpositive increments. */ - - kx = 1; - ky = 1; - if (*incx < 0) { - kx = (1 - *n) * *incx + 1; - } - if (*incy < 0) { - ky = (1 - *n) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - ret_val += (doublereal) sx[kx] * (doublereal) sy[ky]; - kx += *incx; - ky += *incy; -/* L10: */ - } - return ret_val; - -/* Code for equal, positive, non-unit increments. */ - -L20: - ns = *n * *incx; - i__1 = ns; - i__2 = *incx; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - ret_val += (doublereal) sx[i__] * (doublereal) sy[i__]; -/* L30: */ - } - return ret_val; -} /* dsdot_ */ - -#ifdef __cplusplus - } -#endif diff --git a/ext/f2c_blas/dspmv.c b/ext/f2c_blas/dspmv.c deleted file mode 100644 index 48ed4a16c..000000000 --- a/ext/f2c_blas/dspmv.c +++ /dev/null @@ -1,250 +0,0 @@ -#include "blaswrap.h" -#include "f2c.h" - -/* Subroutine */ int dspmv_(char *uplo, integer *n, doublereal *alpha, - doublereal *ap, doublereal *x, integer *incx, doublereal *beta, - doublereal *y, integer *incy) -{ - /* System generated locals */ - integer i__1, i__2; - /* Local variables */ - static integer info; - static doublereal temp1, temp2; - static integer i__, j, k; - extern logical lsame_(char *, char *); - static integer kk, ix, iy, jx, jy, kx, ky; - extern /* Subroutine */ int xerbla_(char *, integer *); -/* Purpose - ======= - DSPMV performs the matrix-vector operation - y := alpha*A*x + beta*y, - where alpha and beta are scalars, x and y are n element vectors and - A is an n by n symmetric matrix, supplied in packed form. - Parameters - ========== - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the upper or lower - triangular part of the matrix A is supplied in the packed - array AP as follows: - UPLO = 'U' or 'u' The upper triangular part of A is - supplied in AP. - UPLO = 'L' or 'l' The lower triangular part of A is - supplied in AP. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the order of the matrix A. - N must be at least zero. - Unchanged on exit. - ALPHA - DOUBLE PRECISION. - On entry, ALPHA specifies the scalar alpha. - Unchanged on exit. - AP - DOUBLE PRECISION array of DIMENSION at least - ( ( n*( n + 1 ) )/2 ). - Before entry with UPLO = 'U' or 'u', the array AP must - contain the upper triangular part of the symmetric matrix - packed sequentially, column by column, so that AP( 1 ) - contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) - and a( 2, 2 ) respectively, and so on. - Before entry with UPLO = 'L' or 'l', the array AP must - contain the lower triangular part of the symmetric matrix - packed sequentially, column by column, so that AP( 1 ) - contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) - and a( 3, 1 ) respectively, and so on. - Unchanged on exit. - X - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCX ) ). - Before entry, the incremented array X must contain the n - element vector x. - Unchanged on exit. - INCX - INTEGER. - On entry, INCX specifies the increment for the elements of - X. INCX must not be zero. - Unchanged on exit. - BETA - DOUBLE PRECISION. - On entry, BETA specifies the scalar beta. When BETA is - supplied as zero then Y need not be set on input. - Unchanged on exit. - Y - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCY ) ). - Before entry, the incremented array Y must contain the n - element vector y. On exit, Y is overwritten by the updated - vector y. - INCY - INTEGER. - On entry, INCY specifies the increment for the elements of - Y. INCY must not be zero. - Unchanged on exit. - Level 2 Blas routine. - -- Written on 22-October-1986. - Jack Dongarra, Argonne National Lab. - Jeremy Du Croz, Nag Central Office. - Sven Hammarling, Nag Central Office. - Richard Hanson, Sandia National Labs. - Test the input parameters. - Parameter adjustments */ - --y; - --x; - --ap; - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 6; - } else if (*incy == 0) { - info = 9; - } - if (info != 0) { - xerbla_("DSPMV ", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0 || *alpha == 0. && *beta == 1.) { - return 0; - } -/* Set up the start points in X and Y. */ - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } -/* Start the operations. In this version the elements of the array AP - are accessed sequentially with one pass through AP. - First form y := beta*y. */ - if (*beta != 1.) { - if (*incy == 1) { - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.; -/* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.; - iy += *incy; -/* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.) { - return 0; - } - kk = 1; - if (lsame_(uplo, "U")) { -/* Form y when AP contains the upper triangle. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - k = kk; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * ap[k]; - temp2 += ap[k] * x[i__]; - ++k; -/* L50: */ - } - y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2; - kk += j; -/* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - ix = kx; - iy = ky; - i__2 = kk + j - 2; - for (k = kk; k <= i__2; ++k) { - y[iy] += temp1 * ap[k]; - temp2 += ap[k] * x[ix]; - ix += *incx; - iy += *incy; -/* L70: */ - } - y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2; - jx += *incx; - jy += *incy; - kk += j; -/* L80: */ - } - } - } else { -/* Form y when AP contains the lower triangle. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - y[j] += temp1 * ap[kk]; - k = kk + 1; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * ap[k]; - temp2 += ap[k] * x[i__]; - ++k; -/* L90: */ - } - y[j] += *alpha * temp2; - kk += *n - j + 1; -/* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - y[jy] += temp1 * ap[kk]; - ix = jx; - iy = jy; - i__2 = kk + *n - j; - for (k = kk + 1; k <= i__2; ++k) { - ix += *incx; - iy += *incy; - y[iy] += temp1 * ap[k]; - temp2 += ap[k] * x[ix]; -/* L110: */ - } - y[jy] += *alpha * temp2; - jx += *incx; - jy += *incy; - kk += *n - j + 1; -/* L120: */ - } - } - } - return 0; -/* End of DSPMV . */ -} /* dspmv_ */ - diff --git a/ext/f2c_blas/dspr.c b/ext/f2c_blas/dspr.c deleted file mode 100644 index 88f86714b..000000000 --- a/ext/f2c_blas/dspr.c +++ /dev/null @@ -1,185 +0,0 @@ -#include "blaswrap.h" -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dspr_(char *uplo, integer *n, doublereal *alpha, - doublereal *x, integer *incx, doublereal *ap) -{ - /* System generated locals */ - integer i__1, i__2; - /* Local variables */ - static integer info; - static doublereal temp; - static integer i__, j, k; - extern logical lsame_(char *, char *); - static integer kk, ix, jx, kx; - extern /* Subroutine */ int xerbla_(char *, integer *); -/* Purpose - ======= - DSPR performs the symmetric rank 1 operation - A := alpha*x*x' + A, - where alpha is a real scalar, x is an n element vector and A is an - n by n symmetric matrix, supplied in packed form. - Parameters - ========== - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the upper or lower - triangular part of the matrix A is supplied in the packed - array AP as follows: - UPLO = 'U' or 'u' The upper triangular part of A is - supplied in AP. - UPLO = 'L' or 'l' The lower triangular part of A is - supplied in AP. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the order of the matrix A. - N must be at least zero. - Unchanged on exit. - ALPHA - DOUBLE PRECISION. - On entry, ALPHA specifies the scalar alpha. - Unchanged on exit. - X - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCX ) ). - Before entry, the incremented array X must contain the n - element vector x. - Unchanged on exit. - INCX - INTEGER. - On entry, INCX specifies the increment for the elements of - X. INCX must not be zero. - Unchanged on exit. - AP - DOUBLE PRECISION array of DIMENSION at least - ( ( n*( n + 1 ) )/2 ). - Before entry with UPLO = 'U' or 'u', the array AP must - contain the upper triangular part of the symmetric matrix - packed sequentially, column by column, so that AP( 1 ) - contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) - and a( 2, 2 ) respectively, and so on. On exit, the array - AP is overwritten by the upper triangular part of the - updated matrix. - Before entry with UPLO = 'L' or 'l', the array AP must - contain the lower triangular part of the symmetric matrix - packed sequentially, column by column, so that AP( 1 ) - contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) - and a( 3, 1 ) respectively, and so on. On exit, the array - AP is overwritten by the lower triangular part of the - updated matrix. - Level 2 Blas routine. - -- Written on 22-October-1986. - Jack Dongarra, Argonne National Lab. - Jeremy Du Croz, Nag Central Office. - Sven Hammarling, Nag Central Office. - Richard Hanson, Sandia National Labs. - Test the input parameters. - Parameter adjustments */ - --ap; - --x; - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 5; - } - if (info != 0) { - xerbla_("DSPR ", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0 || *alpha == 0.) { - return 0; - } -/* Set the start point in X if the increment is not unity. */ - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } -/* Start the operations. In this version the elements of the array AP - are accessed sequentially with one pass through AP. */ - kk = 1; - if (lsame_(uplo, "U")) { -/* Form A when upper triangle is stored in AP. */ - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = *alpha * x[j]; - k = kk; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - ap[k] += x[i__] * temp; - ++k; -/* L10: */ - } - } - kk += j; -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - ix = kx; - i__2 = kk + j - 1; - for (k = kk; k <= i__2; ++k) { - ap[k] += x[ix] * temp; - ix += *incx; -/* L30: */ - } - } - jx += *incx; - kk += j; -/* L40: */ - } - } - } else { -/* Form A when lower triangle is stored in AP. */ - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = *alpha * x[j]; - k = kk; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - ap[k] += x[i__] * temp; - ++k; -/* L50: */ - } - } - kk = kk + *n - j + 1; -/* L60: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - ix = jx; - i__2 = kk + *n - j; - for (k = kk; k <= i__2; ++k) { - ap[k] += x[ix] * temp; - ix += *incx; -/* L70: */ - } - } - jx += *incx; - kk = kk + *n - j + 1; -/* L80: */ - } - } - } - return 0; -/* End of DSPR . */ -} /* dspr_ */ -#ifdef __cplusplus -} -#endif - diff --git a/ext/f2c_blas/dspr2.c b/ext/f2c_blas/dspr2.c deleted file mode 100644 index d90635d24..000000000 --- a/ext/f2c_blas/dspr2.c +++ /dev/null @@ -1,216 +0,0 @@ -#include "blaswrap.h" -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dspr2_(char *uplo, integer *n, doublereal *alpha, - doublereal *x, integer *incx, doublereal *y, integer *incy, - doublereal *ap) -{ - /* System generated locals */ - integer i__1, i__2; - /* Local variables */ - static integer info; - static doublereal temp1, temp2; - static integer i__, j, k; - extern logical lsame_(char *, char *); - static integer kk, ix, iy, jx, jy, kx, ky; - extern /* Subroutine */ int xerbla_(char *, integer *); -/* Purpose - ======= - DSPR2 performs the symmetric rank 2 operation - A := alpha*x*y' + alpha*y*x' + A, - where alpha is a scalar, x and y are n element vectors and A is an - n by n symmetric matrix, supplied in packed form. - Parameters - ========== - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the upper or lower - triangular part of the matrix A is supplied in the packed - array AP as follows: - UPLO = 'U' or 'u' The upper triangular part of A is - supplied in AP. - UPLO = 'L' or 'l' The lower triangular part of A is - supplied in AP. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the order of the matrix A. - N must be at least zero. - Unchanged on exit. - ALPHA - DOUBLE PRECISION. - On entry, ALPHA specifies the scalar alpha. - Unchanged on exit. - X - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCX ) ). - Before entry, the incremented array X must contain the n - element vector x. - Unchanged on exit. - INCX - INTEGER. - On entry, INCX specifies the increment for the elements of - X. INCX must not be zero. - Unchanged on exit. - Y - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCY ) ). - Before entry, the incremented array Y must contain the n - element vector y. - Unchanged on exit. - INCY - INTEGER. - On entry, INCY specifies the increment for the elements of - Y. INCY must not be zero. - Unchanged on exit. - AP - DOUBLE PRECISION array of DIMENSION at least - ( ( n*( n + 1 ) )/2 ). - Before entry with UPLO = 'U' or 'u', the array AP must - contain the upper triangular part of the symmetric matrix - packed sequentially, column by column, so that AP( 1 ) - contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) - and a( 2, 2 ) respectively, and so on. On exit, the array - AP is overwritten by the upper triangular part of the - updated matrix. - Before entry with UPLO = 'L' or 'l', the array AP must - contain the lower triangular part of the symmetric matrix - packed sequentially, column by column, so that AP( 1 ) - contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) - and a( 3, 1 ) respectively, and so on. On exit, the array - AP is overwritten by the lower triangular part of the - updated matrix. - Level 2 Blas routine. - -- Written on 22-October-1986. - Jack Dongarra, Argonne National Lab. - Jeremy Du Croz, Nag Central Office. - Sven Hammarling, Nag Central Office. - Richard Hanson, Sandia National Labs. - Test the input parameters. - Parameter adjustments */ - --ap; - --y; - --x; - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 5; - } else if (*incy == 0) { - info = 7; - } - if (info != 0) { - xerbla_("DSPR2 ", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0 || *alpha == 0.) { - return 0; - } -/* Set up the start points in X and Y if the increments are not both - unity. */ - if (*incx != 1 || *incy != 1) { - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - jx = kx; - jy = ky; - } -/* Start the operations. In this version the elements of the array AP - are accessed sequentially with one pass through AP. */ - kk = 1; - if (lsame_(uplo, "U")) { -/* Form A when upper triangle is stored in AP. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0. || y[j] != 0.) { - temp1 = *alpha * y[j]; - temp2 = *alpha * x[j]; - k = kk; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2; - ++k; -/* L10: */ - } - } - kk += j; -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0. || y[jy] != 0.) { - temp1 = *alpha * y[jy]; - temp2 = *alpha * x[jx]; - ix = kx; - iy = ky; - i__2 = kk + j - 1; - for (k = kk; k <= i__2; ++k) { - ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2; - ix += *incx; - iy += *incy; -/* L30: */ - } - } - jx += *incx; - jy += *incy; - kk += j; -/* L40: */ - } - } - } else { -/* Form A when lower triangle is stored in AP. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0. || y[j] != 0.) { - temp1 = *alpha * y[j]; - temp2 = *alpha * x[j]; - k = kk; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2; - ++k; -/* L50: */ - } - } - kk = kk + *n - j + 1; -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0. || y[jy] != 0.) { - temp1 = *alpha * y[jy]; - temp2 = *alpha * x[jx]; - ix = jx; - iy = jy; - i__2 = kk + *n - j; - for (k = kk; k <= i__2; ++k) { - ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2; - ix += *incx; - iy += *incy; -/* L70: */ - } - } - jx += *incx; - jy += *incy; - kk = kk + *n - j + 1; -/* L80: */ - } - } - } - return 0; -/* End of DSPR2 . */ -} /* dspr2_ */ -#ifdef __cplusplus -} -#endif - diff --git a/ext/f2c_blas/dswap.c b/ext/f2c_blas/dswap.c deleted file mode 100644 index 509413bcc..000000000 --- a/ext/f2c_blas/dswap.c +++ /dev/null @@ -1,87 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dswap_(integer *n, doublereal *dx, integer *incx, - doublereal *dy, integer *incy) -{ - /* System generated locals */ - integer i__1; - /* Local variables */ - static integer i__, m; - static doublereal dtemp; - static integer ix, iy, mp1; -/* interchanges two vectors. - uses unrolled loops for increments equal one. - jack dongarra, linpack, 3/11/78. - modified 12/3/93, array(1) declarations changed to array(*) - Parameter adjustments */ - --dy; - --dx; - /* Function Body */ - if (*n <= 0) { - return 0; - } - if (*incx == 1 && *incy == 1) { - goto L20; - } -/* code for unequal increments or equal increments not equal - to 1 */ - ix = 1; - iy = 1; - if (*incx < 0) { - ix = (-(*n) + 1) * *incx + 1; - } - if (*incy < 0) { - iy = (-(*n) + 1) * *incy + 1; - } - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp = dx[ix]; - dx[ix] = dy[iy]; - dy[iy] = dtemp; - ix += *incx; - iy += *incy; -/* L10: */ - } - return 0; -/* code for both increments equal to 1 - clean-up loop */ -L20: - m = *n % 3; - if (m == 0) { - goto L40; - } - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dtemp = dx[i__]; - dx[i__] = dy[i__]; - dy[i__] = dtemp; -/* L30: */ - } - if (*n < 3) { - return 0; - } -L40: - mp1 = m + 1; - i__1 = *n; - for (i__ = mp1; i__ <= i__1; i__ += 3) { - dtemp = dx[i__]; - dx[i__] = dy[i__]; - dy[i__] = dtemp; - dtemp = dx[i__ + 1]; - dx[i__ + 1] = dy[i__ + 1]; - dy[i__ + 1] = dtemp; - dtemp = dx[i__ + 2]; - dx[i__ + 2] = dy[i__ + 2]; - dy[i__ + 2] = dtemp; -/* L50: */ - } - return 0; -} /* dswap_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/dsymm.c b/ext/f2c_blas/dsymm.c deleted file mode 100644 index 87eef4589..000000000 --- a/ext/f2c_blas/dsymm.c +++ /dev/null @@ -1,298 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dsymm_(char *side, char *uplo, integer *m, integer *n, - doublereal *alpha, doublereal *a, integer *lda, doublereal *b, - integer *ldb, doublereal *beta, doublereal *c__, integer *ldc) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3; - /* Local variables */ - static integer info; - static doublereal temp1, temp2; - static integer i__, j, k; - extern logical lsame_(char *, char *); - static integer nrowa; - static logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] -#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] -/* Purpose - ======= - DSYMM performs one of the matrix-matrix operations - C := alpha*A*B + beta*C, - or - C := alpha*B*A + beta*C, - where alpha and beta are scalars, A is a symmetric matrix and B and - C are m by n matrices. - Parameters - ========== - SIDE - CHARACTER*1. - On entry, SIDE specifies whether the symmetric matrix A - appears on the left or right in the operation as follows: - SIDE = 'L' or 'l' C := alpha*A*B + beta*C, - SIDE = 'R' or 'r' C := alpha*B*A + beta*C, - Unchanged on exit. - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the upper or lower - triangular part of the symmetric matrix A is to be - referenced as follows: - UPLO = 'U' or 'u' Only the upper triangular part of the - symmetric matrix is to be referenced. - UPLO = 'L' or 'l' Only the lower triangular part of the - symmetric matrix is to be referenced. - Unchanged on exit. - M - INTEGER. - On entry, M specifies the number of rows of the matrix C. - M must be at least zero. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the number of columns of the matrix C. - N must be at least zero. - Unchanged on exit. - ALPHA - DOUBLE PRECISION. - On entry, ALPHA specifies the scalar alpha. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is - m when SIDE = 'L' or 'l' and is n otherwise. - Before entry with SIDE = 'L' or 'l', the m by m part of - the array A must contain the symmetric matrix, such that - when UPLO = 'U' or 'u', the leading m by m upper triangular - part of the array A must contain the upper triangular part - of the symmetric matrix and the strictly lower triangular - part of A is not referenced, and when UPLO = 'L' or 'l', - the leading m by m lower triangular part of the array A - must contain the lower triangular part of the symmetric - matrix and the strictly upper triangular part of A is not - referenced. - Before entry with SIDE = 'R' or 'r', the n by n part of - the array A must contain the symmetric matrix, such that - when UPLO = 'U' or 'u', the leading n by n upper triangular - part of the array A must contain the upper triangular part - of the symmetric matrix and the strictly lower triangular - part of A is not referenced, and when UPLO = 'L' or 'l', - the leading n by n lower triangular part of the array A - must contain the lower triangular part of the symmetric - matrix and the strictly upper triangular part of A is not - referenced. - Unchanged on exit. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. When SIDE = 'L' or 'l' then - LDA must be at least max( 1, m ), otherwise LDA must be at - least max( 1, n ). - Unchanged on exit. - B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). - Before entry, the leading m by n part of the array B must - contain the matrix B. - Unchanged on exit. - LDB - INTEGER. - On entry, LDB specifies the first dimension of B as declared - in the calling (sub) program. LDB must be at least - max( 1, m ). - Unchanged on exit. - BETA - DOUBLE PRECISION. - On entry, BETA specifies the scalar beta. When BETA is - supplied as zero then C need not be set on input. - Unchanged on exit. - C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). - Before entry, the leading m by n part of the array C must - contain the matrix C, except when beta is zero, in which - case C need not be set on entry. - On exit, the array C is overwritten by the m by n updated - matrix. - LDC - INTEGER. - On entry, LDC specifies the first dimension of C as declared - in the calling (sub) program. LDC must be at least - max( 1, m ). - Unchanged on exit. - Level 3 Blas routine. - -- Written on 8-February-1989. - Jack Dongarra, Argonne National Laboratory. - Iain Duff, AERE Harwell. - Jeremy Du Croz, Numerical Algorithms Group Ltd. - Sven Hammarling, Numerical Algorithms Group Ltd. - Set NROWA as the number of rows of A. - Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - /* Function Body */ - if (lsame_(side, "L")) { - nrowa = *m; - } else { - nrowa = *n; - } - upper = lsame_(uplo, "U"); -/* Test the input parameters. */ - info = 0; - if (! lsame_(side, "L") && ! lsame_(side, "R")) { - info = 1; - } else if (! upper && ! lsame_(uplo, "L")) { - info = 2; - } else if (*m < 0) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*lda < max(1,nrowa)) { - info = 7; - } else if (*ldb < max(1,*m)) { - info = 9; - } else if (*ldc < max(1,*m)) { - info = 12; - } - if (info != 0) { - xerbla_("DSYMM ", &info); - return 0; - } -/* Quick return if possible. */ - if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { - return 0; - } -/* And when alpha.eq.zero. */ - if (*alpha == 0.) { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = 0.; -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = *beta * c___ref(i__, j); -/* L30: */ - } -/* L40: */ - } - } - return 0; - } -/* Start the operations. */ - if (lsame_(side, "L")) { -/* Form C := alpha*A*B + beta*C. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp1 = *alpha * b_ref(i__, j); - temp2 = 0.; - i__3 = i__ - 1; - for (k = 1; k <= i__3; ++k) { - c___ref(k, j) = c___ref(k, j) + temp1 * a_ref(k, i__); - temp2 += b_ref(k, j) * a_ref(k, i__); -/* L50: */ - } - if (*beta == 0.) { - c___ref(i__, j) = temp1 * a_ref(i__, i__) + *alpha * - temp2; - } else { - c___ref(i__, j) = *beta * c___ref(i__, j) + temp1 * - a_ref(i__, i__) + *alpha * temp2; - } -/* L60: */ - } -/* L70: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - temp1 = *alpha * b_ref(i__, j); - temp2 = 0.; - i__2 = *m; - for (k = i__ + 1; k <= i__2; ++k) { - c___ref(k, j) = c___ref(k, j) + temp1 * a_ref(k, i__); - temp2 += b_ref(k, j) * a_ref(k, i__); -/* L80: */ - } - if (*beta == 0.) { - c___ref(i__, j) = temp1 * a_ref(i__, i__) + *alpha * - temp2; - } else { - c___ref(i__, j) = *beta * c___ref(i__, j) + temp1 * - a_ref(i__, i__) + *alpha * temp2; - } -/* L90: */ - } -/* L100: */ - } - } - } else { -/* Form C := alpha*B*A + beta*C. */ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * a_ref(j, j); - if (*beta == 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = temp1 * b_ref(i__, j); -/* L110: */ - } - } else { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = *beta * c___ref(i__, j) + temp1 * b_ref( - i__, j); -/* L120: */ - } - } - i__2 = j - 1; - for (k = 1; k <= i__2; ++k) { - if (upper) { - temp1 = *alpha * a_ref(k, j); - } else { - temp1 = *alpha * a_ref(j, k); - } - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - c___ref(i__, j) = c___ref(i__, j) + temp1 * b_ref(i__, k); -/* L130: */ - } -/* L140: */ - } - i__2 = *n; - for (k = j + 1; k <= i__2; ++k) { - if (upper) { - temp1 = *alpha * a_ref(j, k); - } else { - temp1 = *alpha * a_ref(k, j); - } - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - c___ref(i__, j) = c___ref(i__, j) + temp1 * b_ref(i__, k); -/* L150: */ - } -/* L160: */ - } -/* L170: */ - } - } - return 0; -/* End of DSYMM . */ -} /* dsymm_ */ -#undef c___ref -#undef b_ref -#undef a_ref - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/dsymv.c b/ext/f2c_blas/dsymv.c deleted file mode 100644 index 5de856bc5..000000000 --- a/ext/f2c_blas/dsymv.c +++ /dev/null @@ -1,256 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dsymv_(char *uplo, integer *n, doublereal *alpha, - doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal - *beta, doublereal *y, integer *incy) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - /* Local variables */ - static integer info; - static doublereal temp1, temp2; - static integer i__, j; - extern logical lsame_(char *, char *); - static integer ix, iy, jx, jy, kx, ky; - extern /* Subroutine */ int xerbla_(char *, integer *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -/* Purpose - ======= - DSYMV performs the matrix-vector operation - y := alpha*A*x + beta*y, - where alpha and beta are scalars, x and y are n element vectors and - A is an n by n symmetric matrix. - Parameters - ========== - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the upper or lower - triangular part of the array A is to be referenced as - follows: - UPLO = 'U' or 'u' Only the upper triangular part of A - is to be referenced. - UPLO = 'L' or 'l' Only the lower triangular part of A - is to be referenced. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the order of the matrix A. - N must be at least zero. - Unchanged on exit. - ALPHA - DOUBLE PRECISION. - On entry, ALPHA specifies the scalar alpha. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). - Before entry with UPLO = 'U' or 'u', the leading n by n - upper triangular part of the array A must contain the upper - triangular part of the symmetric matrix and the strictly - lower triangular part of A is not referenced. - Before entry with UPLO = 'L' or 'l', the leading n by n - lower triangular part of the array A must contain the lower - triangular part of the symmetric matrix and the strictly - upper triangular part of A is not referenced. - Unchanged on exit. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. LDA must be at least - max( 1, n ). - Unchanged on exit. - X - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCX ) ). - Before entry, the incremented array X must contain the n - element vector x. - Unchanged on exit. - INCX - INTEGER. - On entry, INCX specifies the increment for the elements of - X. INCX must not be zero. - Unchanged on exit. - BETA - DOUBLE PRECISION. - On entry, BETA specifies the scalar beta. When BETA is - supplied as zero then Y need not be set on input. - Unchanged on exit. - Y - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCY ) ). - Before entry, the incremented array Y must contain the n - element vector y. On exit, Y is overwritten by the updated - vector y. - INCY - INTEGER. - On entry, INCY specifies the increment for the elements of - Y. INCY must not be zero. - Unchanged on exit. - Level 2 Blas routine. - -- Written on 22-October-1986. - Jack Dongarra, Argonne National Lab. - Jeremy Du Croz, Nag Central Office. - Sven Hammarling, Nag Central Office. - Richard Hanson, Sandia National Labs. - Test the input parameters. - Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --x; - --y; - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*lda < max(1,*n)) { - info = 5; - } else if (*incx == 0) { - info = 7; - } else if (*incy == 0) { - info = 10; - } - if (info != 0) { - xerbla_("DSYMV ", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0 || *alpha == 0. && *beta == 1.) { - return 0; - } -/* Set up the start points in X and Y. */ - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } -/* Start the operations. In this version the elements of A are - accessed sequentially with one pass through the triangular part - of A. - First form y := beta*y. */ - if (*beta != 1.) { - if (*incy == 1) { - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = 0.; -/* L10: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = *beta * y[i__]; -/* L20: */ - } - } - } else { - iy = ky; - if (*beta == 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = 0.; - iy += *incy; -/* L30: */ - } - } else { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - y[iy] = *beta * y[iy]; - iy += *incy; -/* L40: */ - } - } - } - } - if (*alpha == 0.) { - return 0; - } - if (lsame_(uplo, "U")) { -/* Form y when A is stored in upper triangle. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * a_ref(i__, j); - temp2 += a_ref(i__, j) * x[i__]; -/* L50: */ - } - y[j] = y[j] + temp1 * a_ref(j, j) + *alpha * temp2; -/* L60: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - ix = kx; - iy = ky; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - y[iy] += temp1 * a_ref(i__, j); - temp2 += a_ref(i__, j) * x[ix]; - ix += *incx; - iy += *incy; -/* L70: */ - } - y[jy] = y[jy] + temp1 * a_ref(j, j) + *alpha * temp2; - jx += *incx; - jy += *incy; -/* L80: */ - } - } - } else { -/* Form y when A is stored in lower triangle. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[j]; - temp2 = 0.; - y[j] += temp1 * a_ref(j, j); - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - y[i__] += temp1 * a_ref(i__, j); - temp2 += a_ref(i__, j) * x[i__]; -/* L90: */ - } - y[j] += *alpha * temp2; -/* L100: */ - } - } else { - jx = kx; - jy = ky; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp1 = *alpha * x[jx]; - temp2 = 0.; - y[jy] += temp1 * a_ref(j, j); - ix = jx; - iy = jy; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - iy += *incy; - y[iy] += temp1 * a_ref(i__, j); - temp2 += a_ref(i__, j) * x[ix]; -/* L110: */ - } - y[jy] += *alpha * temp2; - jx += *incx; - jy += *incy; -/* L120: */ - } - } - } - return 0; -/* End of DSYMV . */ -} /* dsymv_ */ -#undef a_ref - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/dsyr.c b/ext/f2c_blas/dsyr.c deleted file mode 100644 index 034e512cb..000000000 --- a/ext/f2c_blas/dsyr.c +++ /dev/null @@ -1,185 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dsyr_(char *uplo, integer *n, doublereal *alpha, - doublereal *x, integer *incx, doublereal *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - /* Local variables */ - static integer info; - static doublereal temp; - static integer i__, j; - extern logical lsame_(char *, char *); - static integer ix, jx, kx; - extern /* Subroutine */ int xerbla_(char *, integer *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -/* Purpose - ======= - DSYR performs the symmetric rank 1 operation - A := alpha*x*x' + A, - where alpha is a real scalar, x is an n element vector and A is an - n by n symmetric matrix. - Parameters - ========== - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the upper or lower - triangular part of the array A is to be referenced as - follows: - UPLO = 'U' or 'u' Only the upper triangular part of A - is to be referenced. - UPLO = 'L' or 'l' Only the lower triangular part of A - is to be referenced. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the order of the matrix A. - N must be at least zero. - Unchanged on exit. - ALPHA - DOUBLE PRECISION. - On entry, ALPHA specifies the scalar alpha. - Unchanged on exit. - X - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCX ) ). - Before entry, the incremented array X must contain the n - element vector x. - Unchanged on exit. - INCX - INTEGER. - On entry, INCX specifies the increment for the elements of - X. INCX must not be zero. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). - Before entry with UPLO = 'U' or 'u', the leading n by n - upper triangular part of the array A must contain the upper - triangular part of the symmetric matrix and the strictly - lower triangular part of A is not referenced. On exit, the - upper triangular part of the array A is overwritten by the - upper triangular part of the updated matrix. - Before entry with UPLO = 'L' or 'l', the leading n by n - lower triangular part of the array A must contain the lower - triangular part of the symmetric matrix and the strictly - upper triangular part of A is not referenced. On exit, the - lower triangular part of the array A is overwritten by the - lower triangular part of the updated matrix. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. LDA must be at least - max( 1, n ). - Unchanged on exit. - Level 2 Blas routine. - -- Written on 22-October-1986. - Jack Dongarra, Argonne National Lab. - Jeremy Du Croz, Nag Central Office. - Sven Hammarling, Nag Central Office. - Richard Hanson, Sandia National Labs. - Test the input parameters. - Parameter adjustments */ - --x; - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 5; - } else if (*lda < max(1,*n)) { - info = 7; - } - if (info != 0) { - xerbla_("DSYR ", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0 || *alpha == 0.) { - return 0; - } -/* Set the start point in X if the increment is not unity. */ - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } -/* Start the operations. In this version the elements of A are - accessed sequentially with one pass through the triangular part - of A. */ - if (lsame_(uplo, "U")) { -/* Form A when A is stored in upper triangle. */ - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = *alpha * x[j]; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a_ref(i__, j) = a_ref(i__, j) + x[i__] * temp; -/* L10: */ - } - } -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - ix = kx; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a_ref(i__, j) = a_ref(i__, j) + x[ix] * temp; - ix += *incx; -/* L30: */ - } - } - jx += *incx; -/* L40: */ - } - } - } else { -/* Form A when A is stored in lower triangle. */ - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = *alpha * x[j]; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a_ref(i__, j) = a_ref(i__, j) + x[i__] * temp; -/* L50: */ - } - } -/* L60: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = *alpha * x[jx]; - ix = jx; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a_ref(i__, j) = a_ref(i__, j) + x[ix] * temp; - ix += *incx; -/* L70: */ - } - } - jx += *incx; -/* L80: */ - } - } - } - return 0; -/* End of DSYR . */ -} /* dsyr_ */ -#undef a_ref - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/dsyr2.c b/ext/f2c_blas/dsyr2.c deleted file mode 100644 index 534a77c91..000000000 --- a/ext/f2c_blas/dsyr2.c +++ /dev/null @@ -1,226 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dsyr2_(char *uplo, integer *n, doublereal *alpha, - doublereal *x, integer *incx, doublereal *y, integer *incy, - doublereal *a, integer *lda) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - /* Local variables */ - static integer info; - static doublereal temp1, temp2; - static integer i__, j; - extern logical lsame_(char *, char *); - static integer ix, iy, jx, jy, kx, ky; - extern /* Subroutine */ int xerbla_(char *, integer *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -/* Purpose - ======= - DSYR2 performs the symmetric rank 2 operation - A := alpha*x*y' + alpha*y*x' + A, - where alpha is a scalar, x and y are n element vectors and A is an n - by n symmetric matrix. - Parameters - ========== - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the upper or lower - triangular part of the array A is to be referenced as - follows: - UPLO = 'U' or 'u' Only the upper triangular part of A - is to be referenced. - UPLO = 'L' or 'l' Only the lower triangular part of A - is to be referenced. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the order of the matrix A. - N must be at least zero. - Unchanged on exit. - ALPHA - DOUBLE PRECISION. - On entry, ALPHA specifies the scalar alpha. - Unchanged on exit. - X - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCX ) ). - Before entry, the incremented array X must contain the n - element vector x. - Unchanged on exit. - INCX - INTEGER. - On entry, INCX specifies the increment for the elements of - X. INCX must not be zero. - Unchanged on exit. - Y - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCY ) ). - Before entry, the incremented array Y must contain the n - element vector y. - Unchanged on exit. - INCY - INTEGER. - On entry, INCY specifies the increment for the elements of - Y. INCY must not be zero. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). - Before entry with UPLO = 'U' or 'u', the leading n by n - upper triangular part of the array A must contain the upper - triangular part of the symmetric matrix and the strictly - lower triangular part of A is not referenced. On exit, the - upper triangular part of the array A is overwritten by the - upper triangular part of the updated matrix. - Before entry with UPLO = 'L' or 'l', the leading n by n - lower triangular part of the array A must contain the lower - triangular part of the symmetric matrix and the strictly - upper triangular part of A is not referenced. On exit, the - lower triangular part of the array A is overwritten by the - lower triangular part of the updated matrix. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. LDA must be at least - max( 1, n ). - Unchanged on exit. - Level 2 Blas routine. - -- Written on 22-October-1986. - Jack Dongarra, Argonne National Lab. - Jeremy Du Croz, Nag Central Office. - Sven Hammarling, Nag Central Office. - Richard Hanson, Sandia National Labs. - Test the input parameters. - Parameter adjustments */ - --x; - --y; - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (*n < 0) { - info = 2; - } else if (*incx == 0) { - info = 5; - } else if (*incy == 0) { - info = 7; - } else if (*lda < max(1,*n)) { - info = 9; - } - if (info != 0) { - xerbla_("DSYR2 ", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0 || *alpha == 0.) { - return 0; - } -/* Set up the start points in X and Y if the increments are not both - unity. */ - if (*incx != 1 || *incy != 1) { - if (*incx > 0) { - kx = 1; - } else { - kx = 1 - (*n - 1) * *incx; - } - if (*incy > 0) { - ky = 1; - } else { - ky = 1 - (*n - 1) * *incy; - } - jx = kx; - jy = ky; - } -/* Start the operations. In this version the elements of A are - accessed sequentially with one pass through the triangular part - of A. */ - if (lsame_(uplo, "U")) { -/* Form A when A is stored in the upper triangle. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0. || y[j] != 0.) { - temp1 = *alpha * y[j]; - temp2 = *alpha * x[j]; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a_ref(i__, j) = a_ref(i__, j) + x[i__] * temp1 + y[ - i__] * temp2; -/* L10: */ - } - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0. || y[jy] != 0.) { - temp1 = *alpha * y[jy]; - temp2 = *alpha * x[jx]; - ix = kx; - iy = ky; - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - a_ref(i__, j) = a_ref(i__, j) + x[ix] * temp1 + y[iy] - * temp2; - ix += *incx; - iy += *incy; -/* L30: */ - } - } - jx += *incx; - jy += *incy; -/* L40: */ - } - } - } else { -/* Form A when A is stored in the lower triangle. */ - if (*incx == 1 && *incy == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0. || y[j] != 0.) { - temp1 = *alpha * y[j]; - temp2 = *alpha * x[j]; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a_ref(i__, j) = a_ref(i__, j) + x[i__] * temp1 + y[ - i__] * temp2; -/* L50: */ - } - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0. || y[jy] != 0.) { - temp1 = *alpha * y[jy]; - temp2 = *alpha * x[jx]; - ix = jx; - iy = jy; - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - a_ref(i__, j) = a_ref(i__, j) + x[ix] * temp1 + y[iy] - * temp2; - ix += *incx; - iy += *incy; -/* L70: */ - } - } - jx += *incx; - jy += *incy; -/* L80: */ - } - } - } - return 0; -/* End of DSYR2 . */ -} /* dsyr2_ */ -#undef a_ref - -#ifdef _cpluscplus -} -#endif -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/dsyr2k.c b/ext/f2c_blas/dsyr2k.c deleted file mode 100644 index 53bf883f4..000000000 --- a/ext/f2c_blas/dsyr2k.c +++ /dev/null @@ -1,340 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dsyr2k_(char *uplo, char *trans, integer *n, integer *k, - doublereal *alpha, doublereal *a, integer *lda, doublereal *b, - integer *ldb, doublereal *beta, doublereal *c__, integer *ldc) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, - i__3; - /* Local variables */ - static integer info; - static doublereal temp1, temp2; - static integer i__, j, l; - extern logical lsame_(char *, char *); - static integer nrowa; - static logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] -#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] -/* Purpose - ======= - DSYR2K performs one of the symmetric rank 2k operations - C := alpha*A*B' + alpha*B*A' + beta*C, - or - C := alpha*A'*B + alpha*B'*A + beta*C, - where alpha and beta are scalars, C is an n by n symmetric matrix - and A and B are n by k matrices in the first case and k by n - matrices in the second case. - Parameters - ========== - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the upper or lower - triangular part of the array C is to be referenced as - follows: - UPLO = 'U' or 'u' Only the upper triangular part of C - is to be referenced. - UPLO = 'L' or 'l' Only the lower triangular part of C - is to be referenced. - Unchanged on exit. - TRANS - CHARACTER*1. - On entry, TRANS specifies the operation to be performed as - follows: - TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + - beta*C. - TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + - beta*C. - TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + - beta*C. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the order of the matrix C. N must be - at least zero. - Unchanged on exit. - K - INTEGER. - On entry with TRANS = 'N' or 'n', K specifies the number - of columns of the matrices A and B, and on entry with - TRANS = 'T' or 't' or 'C' or 'c', K specifies the number - of rows of the matrices A and B. K must be at least zero. - Unchanged on exit. - ALPHA - DOUBLE PRECISION. - On entry, ALPHA specifies the scalar alpha. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is - k when TRANS = 'N' or 'n', and is n otherwise. - Before entry with TRANS = 'N' or 'n', the leading n by k - part of the array A must contain the matrix A, otherwise - the leading k by n part of the array A must contain the - matrix A. - Unchanged on exit. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. When TRANS = 'N' or 'n' - then LDA must be at least max( 1, n ), otherwise LDA must - be at least max( 1, k ). - Unchanged on exit. - B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is - k when TRANS = 'N' or 'n', and is n otherwise. - Before entry with TRANS = 'N' or 'n', the leading n by k - part of the array B must contain the matrix B, otherwise - the leading k by n part of the array B must contain the - matrix B. - Unchanged on exit. - LDB - INTEGER. - On entry, LDB specifies the first dimension of B as declared - in the calling (sub) program. When TRANS = 'N' or 'n' - then LDB must be at least max( 1, n ), otherwise LDB must - be at least max( 1, k ). - Unchanged on exit. - BETA - DOUBLE PRECISION. - On entry, BETA specifies the scalar beta. - Unchanged on exit. - C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). - Before entry with UPLO = 'U' or 'u', the leading n by n - upper triangular part of the array C must contain the upper - triangular part of the symmetric matrix and the strictly - lower triangular part of C is not referenced. On exit, the - upper triangular part of the array C is overwritten by the - upper triangular part of the updated matrix. - Before entry with UPLO = 'L' or 'l', the leading n by n - lower triangular part of the array C must contain the lower - triangular part of the symmetric matrix and the strictly - upper triangular part of C is not referenced. On exit, the - lower triangular part of the array C is overwritten by the - lower triangular part of the updated matrix. - LDC - INTEGER. - On entry, LDC specifies the first dimension of C as declared - in the calling (sub) program. LDC must be at least - max( 1, n ). - Unchanged on exit. - Level 3 Blas routine. - -- Written on 8-February-1989. - Jack Dongarra, Argonne National Laboratory. - Iain Duff, AERE Harwell. - Jeremy Du Croz, Numerical Algorithms Group Ltd. - Sven Hammarling, Numerical Algorithms Group Ltd. - Test the input parameters. - Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - /* Function Body */ - if (lsame_(trans, "N")) { - nrowa = *n; - } else { - nrowa = *k; - } - upper = lsame_(uplo, "U"); - info = 0; - if (! upper && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (*n < 0) { - info = 3; - } else if (*k < 0) { - info = 4; - } else if (*lda < max(1,nrowa)) { - info = 7; - } else if (*ldb < max(1,nrowa)) { - info = 9; - } else if (*ldc < max(1,*n)) { - info = 12; - } - if (info != 0) { - xerbla_("DSYR2K", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { - return 0; - } -/* And when alpha.eq.zero. */ - if (*alpha == 0.) { - if (upper) { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = 0.; -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = *beta * c___ref(i__, j); -/* L30: */ - } -/* L40: */ - } - } - } else { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c___ref(i__, j) = 0.; -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c___ref(i__, j) = *beta * c___ref(i__, j); -/* L70: */ - } -/* L80: */ - } - } - } - return 0; - } -/* Start the operations. */ - if (lsame_(trans, "N")) { -/* Form C := alpha*A*B' + alpha*B*A' + C. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = 0.; -/* L90: */ - } - } else if (*beta != 1.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = *beta * c___ref(i__, j); -/* L100: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a_ref(j, l) != 0. || b_ref(j, l) != 0.) { - temp1 = *alpha * b_ref(j, l); - temp2 = *alpha * a_ref(j, l); - i__3 = j; - for (i__ = 1; i__ <= i__3; ++i__) { - c___ref(i__, j) = c___ref(i__, j) + a_ref(i__, l) - * temp1 + b_ref(i__, l) * temp2; -/* L110: */ - } - } -/* L120: */ - } -/* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c___ref(i__, j) = 0.; -/* L140: */ - } - } else if (*beta != 1.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c___ref(i__, j) = *beta * c___ref(i__, j); -/* L150: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a_ref(j, l) != 0. || b_ref(j, l) != 0.) { - temp1 = *alpha * b_ref(j, l); - temp2 = *alpha * a_ref(j, l); - i__3 = *n; - for (i__ = j; i__ <= i__3; ++i__) { - c___ref(i__, j) = c___ref(i__, j) + a_ref(i__, l) - * temp1 + b_ref(i__, l) * temp2; -/* L160: */ - } - } -/* L170: */ - } -/* L180: */ - } - } - } else { -/* Form C := alpha*A'*B + alpha*B'*A + C. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - temp1 = 0.; - temp2 = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp1 += a_ref(l, i__) * b_ref(l, j); - temp2 += b_ref(l, i__) * a_ref(l, j); -/* L190: */ - } - if (*beta == 0.) { - c___ref(i__, j) = *alpha * temp1 + *alpha * temp2; - } else { - c___ref(i__, j) = *beta * c___ref(i__, j) + *alpha * - temp1 + *alpha * temp2; - } -/* L200: */ - } -/* L210: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - temp1 = 0.; - temp2 = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp1 += a_ref(l, i__) * b_ref(l, j); - temp2 += b_ref(l, i__) * a_ref(l, j); -/* L220: */ - } - if (*beta == 0.) { - c___ref(i__, j) = *alpha * temp1 + *alpha * temp2; - } else { - c___ref(i__, j) = *beta * c___ref(i__, j) + *alpha * - temp1 + *alpha * temp2; - } -/* L230: */ - } -/* L240: */ - } - } - } - return 0; -/* End of DSYR2K. */ -} /* dsyr2k_ */ -#undef c___ref -#undef b_ref -#undef a_ref - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/dsyrk.c b/ext/f2c_blas/dsyrk.c deleted file mode 100644 index 41b01803a..000000000 --- a/ext/f2c_blas/dsyrk.c +++ /dev/null @@ -1,310 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dsyrk_(char *uplo, char *trans, integer *n, integer *k, - doublereal *alpha, doublereal *a, integer *lda, doublereal *beta, - doublereal *c__, integer *ldc) -{ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3; - /* Local variables */ - static integer info; - static doublereal temp; - static integer i__, j, l; - extern logical lsame_(char *, char *); - static integer nrowa; - static logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] -/* Purpose - ======= - DSYRK performs one of the symmetric rank k operations - C := alpha*A*A' + beta*C, - or - C := alpha*A'*A + beta*C, - where alpha and beta are scalars, C is an n by n symmetric matrix - and A is an n by k matrix in the first case and a k by n matrix - in the second case. - Parameters - ========== - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the upper or lower - triangular part of the array C is to be referenced as - follows: - UPLO = 'U' or 'u' Only the upper triangular part of C - is to be referenced. - UPLO = 'L' or 'l' Only the lower triangular part of C - is to be referenced. - Unchanged on exit. - TRANS - CHARACTER*1. - On entry, TRANS specifies the operation to be performed as - follows: - TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. - TRANS = 'T' or 't' C := alpha*A'*A + beta*C. - TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the order of the matrix C. N must be - at least zero. - Unchanged on exit. - K - INTEGER. - On entry with TRANS = 'N' or 'n', K specifies the number - of columns of the matrix A, and on entry with - TRANS = 'T' or 't' or 'C' or 'c', K specifies the number - of rows of the matrix A. K must be at least zero. - Unchanged on exit. - ALPHA - DOUBLE PRECISION. - On entry, ALPHA specifies the scalar alpha. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is - k when TRANS = 'N' or 'n', and is n otherwise. - Before entry with TRANS = 'N' or 'n', the leading n by k - part of the array A must contain the matrix A, otherwise - the leading k by n part of the array A must contain the - matrix A. - Unchanged on exit. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. When TRANS = 'N' or 'n' - then LDA must be at least max( 1, n ), otherwise LDA must - be at least max( 1, k ). - Unchanged on exit. - BETA - DOUBLE PRECISION. - On entry, BETA specifies the scalar beta. - Unchanged on exit. - C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). - Before entry with UPLO = 'U' or 'u', the leading n by n - upper triangular part of the array C must contain the upper - triangular part of the symmetric matrix and the strictly - lower triangular part of C is not referenced. On exit, the - upper triangular part of the array C is overwritten by the - upper triangular part of the updated matrix. - Before entry with UPLO = 'L' or 'l', the leading n by n - lower triangular part of the array C must contain the lower - triangular part of the symmetric matrix and the strictly - upper triangular part of C is not referenced. On exit, the - lower triangular part of the array C is overwritten by the - lower triangular part of the updated matrix. - LDC - INTEGER. - On entry, LDC specifies the first dimension of C as declared - in the calling (sub) program. LDC must be at least - max( 1, n ). - Unchanged on exit. - Level 3 Blas routine. - -- Written on 8-February-1989. - Jack Dongarra, Argonne National Laboratory. - Iain Duff, AERE Harwell. - Jeremy Du Croz, Numerical Algorithms Group Ltd. - Sven Hammarling, Numerical Algorithms Group Ltd. - Test the input parameters. - Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - /* Function Body */ - if (lsame_(trans, "N")) { - nrowa = *n; - } else { - nrowa = *k; - } - upper = lsame_(uplo, "U"); - info = 0; - if (! upper && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (*n < 0) { - info = 3; - } else if (*k < 0) { - info = 4; - } else if (*lda < max(1,nrowa)) { - info = 7; - } else if (*ldc < max(1,*n)) { - info = 10; - } - if (info != 0) { - xerbla_("DSYRK ", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { - return 0; - } -/* And when alpha.eq.zero. */ - if (*alpha == 0.) { - if (upper) { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = 0.; -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = *beta * c___ref(i__, j); -/* L30: */ - } -/* L40: */ - } - } - } else { - if (*beta == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c___ref(i__, j) = 0.; -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c___ref(i__, j) = *beta * c___ref(i__, j); -/* L70: */ - } -/* L80: */ - } - } - } - return 0; - } -/* Start the operations. */ - if (lsame_(trans, "N")) { -/* Form C := alpha*A*A' + beta*C. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = 0.; -/* L90: */ - } - } else if (*beta != 1.) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = *beta * c___ref(i__, j); -/* L100: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a_ref(j, l) != 0.) { - temp = *alpha * a_ref(j, l); - i__3 = j; - for (i__ = 1; i__ <= i__3; ++i__) { - c___ref(i__, j) = c___ref(i__, j) + temp * a_ref( - i__, l); -/* L110: */ - } - } -/* L120: */ - } -/* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*beta == 0.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c___ref(i__, j) = 0.; -/* L140: */ - } - } else if (*beta != 1.) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - c___ref(i__, j) = *beta * c___ref(i__, j); -/* L150: */ - } - } - i__2 = *k; - for (l = 1; l <= i__2; ++l) { - if (a_ref(j, l) != 0.) { - temp = *alpha * a_ref(j, l); - i__3 = *n; - for (i__ = j; i__ <= i__3; ++i__) { - c___ref(i__, j) = c___ref(i__, j) + temp * a_ref( - i__, l); -/* L160: */ - } - } -/* L170: */ - } -/* L180: */ - } - } - } else { -/* Form C := alpha*A'*A + beta*C. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a_ref(l, i__) * a_ref(l, j); -/* L190: */ - } - if (*beta == 0.) { - c___ref(i__, j) = *alpha * temp; - } else { - c___ref(i__, j) = *alpha * temp + *beta * c___ref(i__, - j); - } -/* L200: */ - } -/* L210: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { - temp = 0.; - i__3 = *k; - for (l = 1; l <= i__3; ++l) { - temp += a_ref(l, i__) * a_ref(l, j); -/* L220: */ - } - if (*beta == 0.) { - c___ref(i__, j) = *alpha * temp; - } else { - c___ref(i__, j) = *alpha * temp + *beta * c___ref(i__, - j); - } -/* L230: */ - } -/* L240: */ - } - } - } - return 0; -/* End of DSYRK . */ -} /* dsyrk_ */ -#undef c___ref -#undef a_ref - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/dtbmv.c b/ext/f2c_blas/dtbmv.c deleted file mode 100644 index 44a330a5d..000000000 --- a/ext/f2c_blas/dtbmv.c +++ /dev/null @@ -1,354 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dtbmv_(char *uplo, char *trans, char *diag, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - /* Local variables */ - static integer info; - static doublereal temp; - static integer i__, j, l; - extern logical lsame_(char *, char *); - static integer kplus1, ix, jx, kx; - extern /* Subroutine */ int xerbla_(char *, integer *); - static logical nounit; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -/* Purpose - ======= - DTBMV performs one of the matrix-vector operations - x := A*x, or x := A'*x, - where x is an n element vector and A is an n by n unit, or non-unit, - upper or lower triangular band matrix, with ( k + 1 ) diagonals. - Parameters - ========== - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the matrix is an upper or - lower triangular matrix as follows: - UPLO = 'U' or 'u' A is an upper triangular matrix. - UPLO = 'L' or 'l' A is a lower triangular matrix. - Unchanged on exit. - TRANS - CHARACTER*1. - On entry, TRANS specifies the operation to be performed as - follows: - TRANS = 'N' or 'n' x := A*x. - TRANS = 'T' or 't' x := A'*x. - TRANS = 'C' or 'c' x := A'*x. - Unchanged on exit. - DIAG - CHARACTER*1. - On entry, DIAG specifies whether or not A is unit - triangular as follows: - DIAG = 'U' or 'u' A is assumed to be unit triangular. - DIAG = 'N' or 'n' A is not assumed to be unit - triangular. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the order of the matrix A. - N must be at least zero. - Unchanged on exit. - K - INTEGER. - On entry with UPLO = 'U' or 'u', K specifies the number of - super-diagonals of the matrix A. - On entry with UPLO = 'L' or 'l', K specifies the number of - sub-diagonals of the matrix A. - K must satisfy 0 .le. K. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). - Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) - by n part of the array A must contain the upper triangular - band part of the matrix of coefficients, supplied column by - column, with the leading diagonal of the matrix in row - ( k + 1 ) of the array, the first super-diagonal starting at - position 2 in row k, and so on. The top left k by k triangle - of the array A is not referenced. - The following program segment will transfer an upper - triangular band matrix from conventional full matrix storage - to band storage: - DO 20, J = 1, N - M = K + 1 - J - DO 10, I = MAX( 1, J - K ), J - A( M + I, J ) = matrix( I, J ) - 10 CONTINUE - 20 CONTINUE - Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) - by n part of the array A must contain the lower triangular - band part of the matrix of coefficients, supplied column by - column, with the leading diagonal of the matrix in row 1 of - the array, the first sub-diagonal starting at position 1 in - row 2, and so on. The bottom right k by k triangle of the - array A is not referenced. - The following program segment will transfer a lower - triangular band matrix from conventional full matrix storage - to band storage: - DO 20, J = 1, N - M = 1 - J - DO 10, I = J, MIN( N, J + K ) - A( M + I, J ) = matrix( I, J ) - 10 CONTINUE - 20 CONTINUE - Note that when DIAG = 'U' or 'u' the elements of the array A - corresponding to the diagonal elements of the matrix are not - referenced, but are assumed to be unity. - Unchanged on exit. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. LDA must be at least - ( k + 1 ). - Unchanged on exit. - X - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCX ) ). - Before entry, the incremented array X must contain the n - element vector x. On exit, X is overwritten with the - tranformed vector x. - INCX - INTEGER. - On entry, INCX specifies the increment for the elements of - X. INCX must not be zero. - Unchanged on exit. - Level 2 Blas routine. - -- Written on 22-October-1986. - Jack Dongarra, Argonne National Lab. - Jeremy Du Croz, Nag Central Office. - Sven Hammarling, Nag Central Office. - Richard Hanson, Sandia National Labs. - Test the input parameters. - Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --x; - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*k < 0) { - info = 5; - } else if (*lda < *k + 1) { - info = 7; - } else if (*incx == 0) { - info = 9; - } - if (info != 0) { - xerbla_("DTBMV ", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0) { - return 0; - } - nounit = lsame_(diag, "N"); -/* Set up the start point in X if the increment is not unity. This - will be ( N - 1 )*INCX too small for descending loops. */ - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } -/* Start the operations. In this version the elements of A are - accessed sequentially with one pass through A. */ - if (lsame_(trans, "N")) { -/* Form x := A*x. */ - if (lsame_(uplo, "U")) { - kplus1 = *k + 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = x[j]; - l = kplus1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__4 = j - 1; - for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { - x[i__] += temp * a_ref(l + i__, j); -/* L10: */ - } - if (nounit) { - x[j] *= a_ref(kplus1, j); - } - } -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - l = kplus1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *k; - i__3 = j - 1; - for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { - x[ix] += temp * a_ref(l + i__, j); - ix += *incx; -/* L30: */ - } - if (nounit) { - x[jx] *= a_ref(kplus1, j); - } - } - jx += *incx; - if (j > *k) { - kx += *incx; - } -/* L40: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.) { - temp = x[j]; - l = 1 - j; -/* Computing MIN */ - i__1 = *n, i__3 = j + *k; - i__4 = j + 1; - for (i__ = min(i__1,i__3); i__ >= i__4; --i__) { - x[i__] += temp * a_ref(l + i__, j); -/* L50: */ - } - if (nounit) { - x[j] *= a_ref(1, j); - } - } -/* L60: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - l = 1 - j; -/* Computing MIN */ - i__4 = *n, i__1 = j + *k; - i__3 = j + 1; - for (i__ = min(i__4,i__1); i__ >= i__3; --i__) { - x[ix] += temp * a_ref(l + i__, j); - ix -= *incx; -/* L70: */ - } - if (nounit) { - x[jx] *= a_ref(1, j); - } - } - jx -= *incx; - if (*n - j >= *k) { - kx -= *incx; - } -/* L80: */ - } - } - } - } else { -/* Form x := A'*x. */ - if (lsame_(uplo, "U")) { - kplus1 = *k + 1; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - l = kplus1 - j; - if (nounit) { - temp *= a_ref(kplus1, j); - } -/* Computing MAX */ - i__4 = 1, i__1 = j - *k; - i__3 = max(i__4,i__1); - for (i__ = j - 1; i__ >= i__3; --i__) { - temp += a_ref(l + i__, j) * x[i__]; -/* L90: */ - } - x[j] = temp; -/* L100: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - kx -= *incx; - ix = kx; - l = kplus1 - j; - if (nounit) { - temp *= a_ref(kplus1, j); - } -/* Computing MAX */ - i__4 = 1, i__1 = j - *k; - i__3 = max(i__4,i__1); - for (i__ = j - 1; i__ >= i__3; --i__) { - temp += a_ref(l + i__, j) * x[ix]; - ix -= *incx; -/* L110: */ - } - x[jx] = temp; - jx -= *incx; -/* L120: */ - } - } - } else { - if (*incx == 1) { - i__3 = *n; - for (j = 1; j <= i__3; ++j) { - temp = x[j]; - l = 1 - j; - if (nounit) { - temp *= a_ref(1, j); - } -/* Computing MIN */ - i__1 = *n, i__2 = j + *k; - i__4 = min(i__1,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - temp += a_ref(l + i__, j) * x[i__]; -/* L130: */ - } - x[j] = temp; -/* L140: */ - } - } else { - jx = kx; - i__3 = *n; - for (j = 1; j <= i__3; ++j) { - temp = x[jx]; - kx += *incx; - ix = kx; - l = 1 - j; - if (nounit) { - temp *= a_ref(1, j); - } -/* Computing MIN */ - i__1 = *n, i__2 = j + *k; - i__4 = min(i__1,i__2); - for (i__ = j + 1; i__ <= i__4; ++i__) { - temp += a_ref(l + i__, j) * x[ix]; - ix += *incx; -/* L150: */ - } - x[jx] = temp; - jx += *incx; -/* L160: */ - } - } - } - } - return 0; -/* End of DTBMV . */ -} /* dtbmv_ */ -#undef a_ref - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/dtbsv.c b/ext/f2c_blas/dtbsv.c deleted file mode 100644 index 08639385b..000000000 --- a/ext/f2c_blas/dtbsv.c +++ /dev/null @@ -1,357 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dtbsv_(char *uplo, char *trans, char *diag, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - /* Local variables */ - static integer info; - static doublereal temp; - static integer i__, j, l; - extern logical lsame_(char *, char *); - static integer kplus1, ix, jx, kx; - extern /* Subroutine */ int xerbla_(char *, integer *); - static logical nounit; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -/* Purpose - ======= - DTBSV solves one of the systems of equations - A*x = b, or A'*x = b, - where b and x are n element vectors and A is an n by n unit, or - non-unit, upper or lower triangular band matrix, with ( k + 1 ) - diagonals. - No test for singularity or near-singularity is included in this - routine. Such tests must be performed before calling this routine. - Parameters - ========== - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the matrix is an upper or - lower triangular matrix as follows: - UPLO = 'U' or 'u' A is an upper triangular matrix. - UPLO = 'L' or 'l' A is a lower triangular matrix. - Unchanged on exit. - TRANS - CHARACTER*1. - On entry, TRANS specifies the equations to be solved as - follows: - TRANS = 'N' or 'n' A*x = b. - TRANS = 'T' or 't' A'*x = b. - TRANS = 'C' or 'c' A'*x = b. - Unchanged on exit. - DIAG - CHARACTER*1. - On entry, DIAG specifies whether or not A is unit - triangular as follows: - DIAG = 'U' or 'u' A is assumed to be unit triangular. - DIAG = 'N' or 'n' A is not assumed to be unit - triangular. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the order of the matrix A. - N must be at least zero. - Unchanged on exit. - K - INTEGER. - On entry with UPLO = 'U' or 'u', K specifies the number of - super-diagonals of the matrix A. - On entry with UPLO = 'L' or 'l', K specifies the number of - sub-diagonals of the matrix A. - K must satisfy 0 .le. K. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). - Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) - by n part of the array A must contain the upper triangular - band part of the matrix of coefficients, supplied column by - column, with the leading diagonal of the matrix in row - ( k + 1 ) of the array, the first super-diagonal starting at - position 2 in row k, and so on. The top left k by k triangle - of the array A is not referenced. - The following program segment will transfer an upper - triangular band matrix from conventional full matrix storage - to band storage: - DO 20, J = 1, N - M = K + 1 - J - DO 10, I = MAX( 1, J - K ), J - A( M + I, J ) = matrix( I, J ) - 10 CONTINUE - 20 CONTINUE - Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) - by n part of the array A must contain the lower triangular - band part of the matrix of coefficients, supplied column by - column, with the leading diagonal of the matrix in row 1 of - the array, the first sub-diagonal starting at position 1 in - row 2, and so on. The bottom right k by k triangle of the - array A is not referenced. - The following program segment will transfer a lower - triangular band matrix from conventional full matrix storage - to band storage: - DO 20, J = 1, N - M = 1 - J - DO 10, I = J, MIN( N, J + K ) - A( M + I, J ) = matrix( I, J ) - 10 CONTINUE - 20 CONTINUE - Note that when DIAG = 'U' or 'u' the elements of the array A - corresponding to the diagonal elements of the matrix are not - referenced, but are assumed to be unity. - Unchanged on exit. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. LDA must be at least - ( k + 1 ). - Unchanged on exit. - X - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCX ) ). - Before entry, the incremented array X must contain the n - element right-hand side vector b. On exit, X is overwritten - with the solution vector x. - INCX - INTEGER. - On entry, INCX specifies the increment for the elements of - X. INCX must not be zero. - Unchanged on exit. - Level 2 Blas routine. - -- Written on 22-October-1986. - Jack Dongarra, Argonne National Lab. - Jeremy Du Croz, Nag Central Office. - Sven Hammarling, Nag Central Office. - Richard Hanson, Sandia National Labs. - Test the input parameters. - Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --x; - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*k < 0) { - info = 5; - } else if (*lda < *k + 1) { - info = 7; - } else if (*incx == 0) { - info = 9; - } - if (info != 0) { - xerbla_("DTBSV ", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0) { - return 0; - } - nounit = lsame_(diag, "N"); -/* Set up the start point in X if the increment is not unity. This - will be ( N - 1 )*INCX too small for descending loops. */ - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } -/* Start the operations. In this version the elements of A are - accessed by sequentially with one pass through A. */ - if (lsame_(trans, "N")) { -/* Form x := inv( A )*x. */ - if (lsame_(uplo, "U")) { - kplus1 = *k + 1; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.) { - l = kplus1 - j; - if (nounit) { - x[j] /= a_ref(kplus1, j); - } - temp = x[j]; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__1 = max(i__2,i__3); - for (i__ = j - 1; i__ >= i__1; --i__) { - x[i__] -= temp * a_ref(l + i__, j); -/* L10: */ - } - } -/* L20: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - kx -= *incx; - if (x[jx] != 0.) { - ix = kx; - l = kplus1 - j; - if (nounit) { - x[jx] /= a_ref(kplus1, j); - } - temp = x[jx]; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__1 = max(i__2,i__3); - for (i__ = j - 1; i__ >= i__1; --i__) { - x[ix] -= temp * a_ref(l + i__, j); - ix -= *incx; -/* L30: */ - } - } - jx -= *incx; -/* L40: */ - } - } - } else { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - l = 1 - j; - if (nounit) { - x[j] /= a_ref(1, j); - } - temp = x[j]; -/* Computing MIN */ - i__3 = *n, i__4 = j + *k; - i__2 = min(i__3,i__4); - for (i__ = j + 1; i__ <= i__2; ++i__) { - x[i__] -= temp * a_ref(l + i__, j); -/* L50: */ - } - } -/* L60: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - kx += *incx; - if (x[jx] != 0.) { - ix = kx; - l = 1 - j; - if (nounit) { - x[jx] /= a_ref(1, j); - } - temp = x[jx]; -/* Computing MIN */ - i__3 = *n, i__4 = j + *k; - i__2 = min(i__3,i__4); - for (i__ = j + 1; i__ <= i__2; ++i__) { - x[ix] -= temp * a_ref(l + i__, j); - ix += *incx; -/* L70: */ - } - } - jx += *incx; -/* L80: */ - } - } - } - } else { -/* Form x := inv( A')*x. */ - if (lsame_(uplo, "U")) { - kplus1 = *k + 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[j]; - l = kplus1 - j; -/* Computing MAX */ - i__2 = 1, i__3 = j - *k; - i__4 = j - 1; - for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) { - temp -= a_ref(l + i__, j) * x[i__]; -/* L90: */ - } - if (nounit) { - temp /= a_ref(kplus1, j); - } - x[j] = temp; -/* L100: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[jx]; - ix = kx; - l = kplus1 - j; -/* Computing MAX */ - i__4 = 1, i__2 = j - *k; - i__3 = j - 1; - for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) { - temp -= a_ref(l + i__, j) * x[ix]; - ix += *incx; -/* L110: */ - } - if (nounit) { - temp /= a_ref(kplus1, j); - } - x[jx] = temp; - jx += *incx; - if (j > *k) { - kx += *incx; - } -/* L120: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - l = 1 - j; -/* Computing MIN */ - i__1 = *n, i__3 = j + *k; - i__4 = j + 1; - for (i__ = min(i__1,i__3); i__ >= i__4; --i__) { - temp -= a_ref(l + i__, j) * x[i__]; -/* L130: */ - } - if (nounit) { - temp /= a_ref(1, j); - } - x[j] = temp; -/* L140: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - ix = kx; - l = 1 - j; -/* Computing MIN */ - i__4 = *n, i__1 = j + *k; - i__3 = j + 1; - for (i__ = min(i__4,i__1); i__ >= i__3; --i__) { - temp -= a_ref(l + i__, j) * x[ix]; - ix -= *incx; -/* L150: */ - } - if (nounit) { - temp /= a_ref(1, j); - } - x[jx] = temp; - jx -= *incx; - if (*n - j >= *k) { - kx -= *incx; - } -/* L160: */ - } - } - } - } - return 0; -/* End of DTBSV . */ -} /* dtbsv_ */ -#undef a_ref - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/dtpmv.c b/ext/f2c_blas/dtpmv.c deleted file mode 100644 index cc8799def..000000000 --- a/ext/f2c_blas/dtpmv.c +++ /dev/null @@ -1,296 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dtpmv_(char *uplo, char *trans, char *diag, integer *n, - doublereal *ap, doublereal *x, integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - /* Local variables */ - static integer info; - static doublereal temp; - static integer i__, j, k; - extern logical lsame_(char *, char *); - static integer kk, ix, jx, kx; - extern /* Subroutine */ int xerbla_(char *, integer *); - static logical nounit; -/* Purpose - ======= - DTPMV performs one of the matrix-vector operations - x := A*x, or x := A'*x, - where x is an n element vector and A is an n by n unit, or non-unit, - upper or lower triangular matrix, supplied in packed form. - Parameters - ========== - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the matrix is an upper or - lower triangular matrix as follows: - UPLO = 'U' or 'u' A is an upper triangular matrix. - UPLO = 'L' or 'l' A is a lower triangular matrix. - Unchanged on exit. - TRANS - CHARACTER*1. - On entry, TRANS specifies the operation to be performed as - follows: - TRANS = 'N' or 'n' x := A*x. - TRANS = 'T' or 't' x := A'*x. - TRANS = 'C' or 'c' x := A'*x. - Unchanged on exit. - DIAG - CHARACTER*1. - On entry, DIAG specifies whether or not A is unit - triangular as follows: - DIAG = 'U' or 'u' A is assumed to be unit triangular. - DIAG = 'N' or 'n' A is not assumed to be unit - triangular. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the order of the matrix A. - N must be at least zero. - Unchanged on exit. - AP - DOUBLE PRECISION array of DIMENSION at least - ( ( n*( n + 1 ) )/2 ). - Before entry with UPLO = 'U' or 'u', the array AP must - contain the upper triangular matrix packed sequentially, - column by column, so that AP( 1 ) contains a( 1, 1 ), - AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) - respectively, and so on. - Before entry with UPLO = 'L' or 'l', the array AP must - contain the lower triangular matrix packed sequentially, - column by column, so that AP( 1 ) contains a( 1, 1 ), - AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) - respectively, and so on. - Note that when DIAG = 'U' or 'u', the diagonal elements of - A are not referenced, but are assumed to be unity. - Unchanged on exit. - X - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCX ) ). - Before entry, the incremented array X must contain the n - element vector x. On exit, X is overwritten with the - tranformed vector x. - INCX - INTEGER. - On entry, INCX specifies the increment for the elements of - X. INCX must not be zero. - Unchanged on exit. - Level 2 Blas routine. - -- Written on 22-October-1986. - Jack Dongarra, Argonne National Lab. - Jeremy Du Croz, Nag Central Office. - Sven Hammarling, Nag Central Office. - Richard Hanson, Sandia National Labs. - Test the input parameters. - Parameter adjustments */ - --x; - --ap; - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*incx == 0) { - info = 7; - } - if (info != 0) { - xerbla_("DTPMV ", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0) { - return 0; - } - nounit = lsame_(diag, "N"); -/* Set up the start point in X if the increment is not unity. This - will be ( N - 1 )*INCX too small for descending loops. */ - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } -/* Start the operations. In this version the elements of AP are - accessed sequentially with one pass through AP. */ - if (lsame_(trans, "N")) { -/* Form x:= A*x. */ - if (lsame_(uplo, "U")) { - kk = 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = x[j]; - k = kk; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - x[i__] += temp * ap[k]; - ++k; -/* L10: */ - } - if (nounit) { - x[j] *= ap[kk + j - 1]; - } - } - kk += j; -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - i__2 = kk + j - 2; - for (k = kk; k <= i__2; ++k) { - x[ix] += temp * ap[k]; - ix += *incx; -/* L30: */ - } - if (nounit) { - x[jx] *= ap[kk + j - 1]; - } - } - jx += *incx; - kk += j; -/* L40: */ - } - } - } else { - kk = *n * (*n + 1) / 2; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.) { - temp = x[j]; - k = kk; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - x[i__] += temp * ap[k]; - --k; -/* L50: */ - } - if (nounit) { - x[j] *= ap[kk - *n + j]; - } - } - kk -= *n - j + 1; -/* L60: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - i__1 = kk - (*n - (j + 1)); - for (k = kk; k >= i__1; --k) { - x[ix] += temp * ap[k]; - ix -= *incx; -/* L70: */ - } - if (nounit) { - x[jx] *= ap[kk - *n + j]; - } - } - jx -= *incx; - kk -= *n - j + 1; -/* L80: */ - } - } - } - } else { -/* Form x := A'*x. */ - if (lsame_(uplo, "U")) { - kk = *n * (*n + 1) / 2; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - if (nounit) { - temp *= ap[kk]; - } - k = kk - 1; - for (i__ = j - 1; i__ >= 1; --i__) { - temp += ap[k] * x[i__]; - --k; -/* L90: */ - } - x[j] = temp; - kk -= j; -/* L100: */ - } - } else { - jx = kx + (*n - 1) * *incx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - ix = jx; - if (nounit) { - temp *= ap[kk]; - } - i__1 = kk - j + 1; - for (k = kk - 1; k >= i__1; --k) { - ix -= *incx; - temp += ap[k] * x[ix]; -/* L110: */ - } - x[jx] = temp; - jx -= *incx; - kk -= j; -/* L120: */ - } - } - } else { - kk = 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[j]; - if (nounit) { - temp *= ap[kk]; - } - k = kk + 1; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - temp += ap[k] * x[i__]; - ++k; -/* L130: */ - } - x[j] = temp; - kk += *n - j + 1; -/* L140: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[jx]; - ix = jx; - if (nounit) { - temp *= ap[kk]; - } - i__2 = kk + *n - j; - for (k = kk + 1; k <= i__2; ++k) { - ix += *incx; - temp += ap[k] * x[ix]; -/* L150: */ - } - x[jx] = temp; - jx += *incx; - kk += *n - j + 1; -/* L160: */ - } - } - } - } - return 0; -/* End of DTPMV . */ -} /* dtpmv_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/dtpsv.c b/ext/f2c_blas/dtpsv.c deleted file mode 100644 index 475c38d0f..000000000 --- a/ext/f2c_blas/dtpsv.c +++ /dev/null @@ -1,298 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dtpsv_(char *uplo, char *trans, char *diag, integer *n, - doublereal *ap, doublereal *x, integer *incx) -{ - /* System generated locals */ - integer i__1, i__2; - /* Local variables */ - static integer info; - static doublereal temp; - static integer i__, j, k; - extern logical lsame_(char *, char *); - static integer kk, ix, jx, kx; - extern /* Subroutine */ int xerbla_(char *, integer *); - static logical nounit; -/* Purpose - ======= - DTPSV solves one of the systems of equations - A*x = b, or A'*x = b, - where b and x are n element vectors and A is an n by n unit, or - non-unit, upper or lower triangular matrix, supplied in packed form. - No test for singularity or near-singularity is included in this - routine. Such tests must be performed before calling this routine. - Parameters - ========== - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the matrix is an upper or - lower triangular matrix as follows: - UPLO = 'U' or 'u' A is an upper triangular matrix. - UPLO = 'L' or 'l' A is a lower triangular matrix. - Unchanged on exit. - TRANS - CHARACTER*1. - On entry, TRANS specifies the equations to be solved as - follows: - TRANS = 'N' or 'n' A*x = b. - TRANS = 'T' or 't' A'*x = b. - TRANS = 'C' or 'c' A'*x = b. - Unchanged on exit. - DIAG - CHARACTER*1. - On entry, DIAG specifies whether or not A is unit - triangular as follows: - DIAG = 'U' or 'u' A is assumed to be unit triangular. - DIAG = 'N' or 'n' A is not assumed to be unit - triangular. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the order of the matrix A. - N must be at least zero. - Unchanged on exit. - AP - DOUBLE PRECISION array of DIMENSION at least - ( ( n*( n + 1 ) )/2 ). - Before entry with UPLO = 'U' or 'u', the array AP must - contain the upper triangular matrix packed sequentially, - column by column, so that AP( 1 ) contains a( 1, 1 ), - AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) - respectively, and so on. - Before entry with UPLO = 'L' or 'l', the array AP must - contain the lower triangular matrix packed sequentially, - column by column, so that AP( 1 ) contains a( 1, 1 ), - AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) - respectively, and so on. - Note that when DIAG = 'U' or 'u', the diagonal elements of - A are not referenced, but are assumed to be unity. - Unchanged on exit. - X - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCX ) ). - Before entry, the incremented array X must contain the n - element right-hand side vector b. On exit, X is overwritten - with the solution vector x. - INCX - INTEGER. - On entry, INCX specifies the increment for the elements of - X. INCX must not be zero. - Unchanged on exit. - Level 2 Blas routine. - -- Written on 22-October-1986. - Jack Dongarra, Argonne National Lab. - Jeremy Du Croz, Nag Central Office. - Sven Hammarling, Nag Central Office. - Richard Hanson, Sandia National Labs. - Test the input parameters. - Parameter adjustments */ - --x; - --ap; - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*incx == 0) { - info = 7; - } - if (info != 0) { - xerbla_("DTPSV ", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0) { - return 0; - } - nounit = lsame_(diag, "N"); -/* Set up the start point in X if the increment is not unity. This - will be ( N - 1 )*INCX too small for descending loops. */ - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } -/* Start the operations. In this version the elements of AP are - accessed sequentially with one pass through AP. */ - if (lsame_(trans, "N")) { -/* Form x := inv( A )*x. */ - if (lsame_(uplo, "U")) { - kk = *n * (*n + 1) / 2; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.) { - if (nounit) { - x[j] /= ap[kk]; - } - temp = x[j]; - k = kk - 1; - for (i__ = j - 1; i__ >= 1; --i__) { - x[i__] -= temp * ap[k]; - --k; -/* L10: */ - } - } - kk -= j; -/* L20: */ - } - } else { - jx = kx + (*n - 1) * *incx; - for (j = *n; j >= 1; --j) { - if (x[jx] != 0.) { - if (nounit) { - x[jx] /= ap[kk]; - } - temp = x[jx]; - ix = jx; - i__1 = kk - j + 1; - for (k = kk - 1; k >= i__1; --k) { - ix -= *incx; - x[ix] -= temp * ap[k]; -/* L30: */ - } - } - jx -= *incx; - kk -= j; -/* L40: */ - } - } - } else { - kk = 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - if (nounit) { - x[j] /= ap[kk]; - } - temp = x[j]; - k = kk + 1; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - x[i__] -= temp * ap[k]; - ++k; -/* L50: */ - } - } - kk += *n - j + 1; -/* L60: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - if (nounit) { - x[jx] /= ap[kk]; - } - temp = x[jx]; - ix = jx; - i__2 = kk + *n - j; - for (k = kk + 1; k <= i__2; ++k) { - ix += *incx; - x[ix] -= temp * ap[k]; -/* L70: */ - } - } - jx += *incx; - kk += *n - j + 1; -/* L80: */ - } - } - } - } else { -/* Form x := inv( A' )*x. */ - if (lsame_(uplo, "U")) { - kk = 1; - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[j]; - k = kk; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - temp -= ap[k] * x[i__]; - ++k; -/* L90: */ - } - if (nounit) { - temp /= ap[kk + j - 1]; - } - x[j] = temp; - kk += j; -/* L100: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[jx]; - ix = kx; - i__2 = kk + j - 2; - for (k = kk; k <= i__2; ++k) { - temp -= ap[k] * x[ix]; - ix += *incx; -/* L110: */ - } - if (nounit) { - temp /= ap[kk + j - 1]; - } - x[jx] = temp; - jx += *incx; - kk += j; -/* L120: */ - } - } - } else { - kk = *n * (*n + 1) / 2; - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - k = kk; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - temp -= ap[k] * x[i__]; - --k; -/* L130: */ - } - if (nounit) { - temp /= ap[kk - *n + j]; - } - x[j] = temp; - kk -= *n - j + 1; -/* L140: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - ix = kx; - i__1 = kk - (*n - (j + 1)); - for (k = kk; k >= i__1; --k) { - temp -= ap[k] * x[ix]; - ix -= *incx; -/* L150: */ - } - if (nounit) { - temp /= ap[kk - *n + j]; - } - x[jx] = temp; - jx -= *incx; - kk -= *n - j + 1; -/* L160: */ - } - } - } - } - return 0; -/* End of DTPSV . */ -} /* dtpsv_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/dtrmm.c b/ext/f2c_blas/dtrmm.c deleted file mode 100644 index fa6e6e942..000000000 --- a/ext/f2c_blas/dtrmm.c +++ /dev/null @@ -1,381 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dtrmm_(char *side, char *uplo, char *transa, char *diag, - integer *m, integer *n, doublereal *alpha, doublereal *a, integer * - lda, doublereal *b, integer *ldb) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; - /* Local variables */ - static integer info; - static doublereal temp; - static integer i__, j, k; - static logical lside; - extern logical lsame_(char *, char *); - static integer nrowa; - static logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *); - static logical nounit; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] -/* Purpose - ======= - DTRMM performs one of the matrix-matrix operations - B := alpha*op( A )*B, or B := alpha*B*op( A ), - where alpha is a scalar, B is an m by n matrix, A is a unit, or - non-unit, upper or lower triangular matrix and op( A ) is one of - op( A ) = A or op( A ) = A'. - Parameters - ========== - SIDE - CHARACTER*1. - On entry, SIDE specifies whether op( A ) multiplies B from - the left or right as follows: - SIDE = 'L' or 'l' B := alpha*op( A )*B. - SIDE = 'R' or 'r' B := alpha*B*op( A ). - Unchanged on exit. - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the matrix A is an upper or - lower triangular matrix as follows: - UPLO = 'U' or 'u' A is an upper triangular matrix. - UPLO = 'L' or 'l' A is a lower triangular matrix. - Unchanged on exit. - TRANSA - CHARACTER*1. - On entry, TRANSA specifies the form of op( A ) to be used in - the matrix multiplication as follows: - TRANSA = 'N' or 'n' op( A ) = A. - TRANSA = 'T' or 't' op( A ) = A'. - TRANSA = 'C' or 'c' op( A ) = A'. - Unchanged on exit. - DIAG - CHARACTER*1. - On entry, DIAG specifies whether or not A is unit triangular - as follows: - DIAG = 'U' or 'u' A is assumed to be unit triangular. - DIAG = 'N' or 'n' A is not assumed to be unit - triangular. - Unchanged on exit. - M - INTEGER. - On entry, M specifies the number of rows of B. M must be at - least zero. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the number of columns of B. N must be - at least zero. - Unchanged on exit. - ALPHA - DOUBLE PRECISION. - On entry, ALPHA specifies the scalar alpha. When alpha is - zero then A is not referenced and B need not be set before - entry. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m - when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. - Before entry with UPLO = 'U' or 'u', the leading k by k - upper triangular part of the array A must contain the upper - triangular matrix and the strictly lower triangular part of - A is not referenced. - Before entry with UPLO = 'L' or 'l', the leading k by k - lower triangular part of the array A must contain the lower - triangular matrix and the strictly upper triangular part of - A is not referenced. - Note that when DIAG = 'U' or 'u', the diagonal elements of - A are not referenced either, but are assumed to be unity. - Unchanged on exit. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. When SIDE = 'L' or 'l' then - LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' - then LDA must be at least max( 1, n ). - Unchanged on exit. - B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). - Before entry, the leading m by n part of the array B must - contain the matrix B, and on exit is overwritten by the - transformed matrix. - LDB - INTEGER. - On entry, LDB specifies the first dimension of B as declared - in the calling (sub) program. LDB must be at least - max( 1, m ). - Unchanged on exit. - Level 3 Blas routine. - -- Written on 8-February-1989. - Jack Dongarra, Argonne National Laboratory. - Iain Duff, AERE Harwell. - Jeremy Du Croz, Numerical Algorithms Group Ltd. - Sven Hammarling, Numerical Algorithms Group Ltd. - Test the input parameters. - Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - /* Function Body */ - lside = lsame_(side, "L"); - if (lside) { - nrowa = *m; - } else { - nrowa = *n; - } - nounit = lsame_(diag, "N"); - upper = lsame_(uplo, "U"); - info = 0; - if (! lside && ! lsame_(side, "R")) { - info = 1; - } else if (! upper && ! lsame_(uplo, "L")) { - info = 2; - } else if (! lsame_(transa, "N") && ! lsame_(transa, - "T") && ! lsame_(transa, "C")) { - info = 3; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 4; - } else if (*m < 0) { - info = 5; - } else if (*n < 0) { - info = 6; - } else if (*lda < max(1,nrowa)) { - info = 9; - } else if (*ldb < max(1,*m)) { - info = 11; - } - if (info != 0) { - xerbla_("DTRMM ", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0) { - return 0; - } -/* And when alpha.eq.zero. */ - if (*alpha == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = 0.; -/* L10: */ - } -/* L20: */ - } - return 0; - } -/* Start the operations. */ - if (lside) { - if (lsame_(transa, "N")) { -/* Form B := alpha*A*B. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (k = 1; k <= i__2; ++k) { - if (b_ref(k, j) != 0.) { - temp = *alpha * b_ref(k, j); - i__3 = k - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - b_ref(i__, j) = b_ref(i__, j) + temp * a_ref( - i__, k); -/* L30: */ - } - if (nounit) { - temp *= a_ref(k, k); - } - b_ref(k, j) = temp; - } -/* L40: */ - } -/* L50: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (k = *m; k >= 1; --k) { - if (b_ref(k, j) != 0.) { - temp = *alpha * b_ref(k, j); - b_ref(k, j) = temp; - if (nounit) { - b_ref(k, j) = b_ref(k, j) * a_ref(k, k); - } - i__2 = *m; - for (i__ = k + 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = b_ref(i__, j) + temp * a_ref( - i__, k); -/* L60: */ - } - } -/* L70: */ - } -/* L80: */ - } - } - } else { -/* Form B := alpha*A'*B. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - temp = b_ref(i__, j); - if (nounit) { - temp *= a_ref(i__, i__); - } - i__2 = i__ - 1; - for (k = 1; k <= i__2; ++k) { - temp += a_ref(k, i__) * b_ref(k, j); -/* L90: */ - } - b_ref(i__, j) = *alpha * temp; -/* L100: */ - } -/* L110: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = b_ref(i__, j); - if (nounit) { - temp *= a_ref(i__, i__); - } - i__3 = *m; - for (k = i__ + 1; k <= i__3; ++k) { - temp += a_ref(k, i__) * b_ref(k, j); -/* L120: */ - } - b_ref(i__, j) = *alpha * temp; -/* L130: */ - } -/* L140: */ - } - } - } - } else { - if (lsame_(transa, "N")) { -/* Form B := alpha*B*A. */ - if (upper) { - for (j = *n; j >= 1; --j) { - temp = *alpha; - if (nounit) { - temp *= a_ref(j, j); - } - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b_ref(i__, j) = temp * b_ref(i__, j); -/* L150: */ - } - i__1 = j - 1; - for (k = 1; k <= i__1; ++k) { - if (a_ref(k, j) != 0.) { - temp = *alpha * a_ref(k, j); - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = b_ref(i__, j) + temp * b_ref( - i__, k); -/* L160: */ - } - } -/* L170: */ - } -/* L180: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = *alpha; - if (nounit) { - temp *= a_ref(j, j); - } - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = temp * b_ref(i__, j); -/* L190: */ - } - i__2 = *n; - for (k = j + 1; k <= i__2; ++k) { - if (a_ref(k, j) != 0.) { - temp = *alpha * a_ref(k, j); - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b_ref(i__, j) = b_ref(i__, j) + temp * b_ref( - i__, k); -/* L200: */ - } - } -/* L210: */ - } -/* L220: */ - } - } - } else { -/* Form B := alpha*B*A'. */ - if (upper) { - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - i__2 = k - 1; - for (j = 1; j <= i__2; ++j) { - if (a_ref(j, k) != 0.) { - temp = *alpha * a_ref(j, k); - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b_ref(i__, j) = b_ref(i__, j) + temp * b_ref( - i__, k); -/* L230: */ - } - } -/* L240: */ - } - temp = *alpha; - if (nounit) { - temp *= a_ref(k, k); - } - if (temp != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, k) = temp * b_ref(i__, k); -/* L250: */ - } - } -/* L260: */ - } - } else { - for (k = *n; k >= 1; --k) { - i__1 = *n; - for (j = k + 1; j <= i__1; ++j) { - if (a_ref(j, k) != 0.) { - temp = *alpha * a_ref(j, k); - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = b_ref(i__, j) + temp * b_ref( - i__, k); -/* L270: */ - } - } -/* L280: */ - } - temp = *alpha; - if (nounit) { - temp *= a_ref(k, k); - } - if (temp != 1.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b_ref(i__, k) = temp * b_ref(i__, k); -/* L290: */ - } - } -/* L300: */ - } - } - } - } - return 0; -/* End of DTRMM . */ -} /* dtrmm_ */ -#undef b_ref -#undef a_ref - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/dtrmv.c b/ext/f2c_blas/dtrmv.c deleted file mode 100644 index e94a5f62b..000000000 --- a/ext/f2c_blas/dtrmv.c +++ /dev/null @@ -1,283 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dtrmv_(char *uplo, char *trans, char *diag, integer *n, - doublereal *a, integer *lda, doublereal *x, integer *incx) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - /* Local variables */ - static integer info; - static doublereal temp; - static integer i__, j; - extern logical lsame_(char *, char *); - static integer ix, jx, kx; - extern /* Subroutine */ int xerbla_(char *, integer *); - static logical nounit; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -/* Purpose - ======= - DTRMV performs one of the matrix-vector operations - x := A*x, or x := A'*x, - where x is an n element vector and A is an n by n unit, or non-unit, - upper or lower triangular matrix. - Parameters - ========== - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the matrix is an upper or - lower triangular matrix as follows: - UPLO = 'U' or 'u' A is an upper triangular matrix. - UPLO = 'L' or 'l' A is a lower triangular matrix. - Unchanged on exit. - TRANS - CHARACTER*1. - On entry, TRANS specifies the operation to be performed as - follows: - TRANS = 'N' or 'n' x := A*x. - TRANS = 'T' or 't' x := A'*x. - TRANS = 'C' or 'c' x := A'*x. - Unchanged on exit. - DIAG - CHARACTER*1. - On entry, DIAG specifies whether or not A is unit - triangular as follows: - DIAG = 'U' or 'u' A is assumed to be unit triangular. - DIAG = 'N' or 'n' A is not assumed to be unit - triangular. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the order of the matrix A. - N must be at least zero. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). - Before entry with UPLO = 'U' or 'u', the leading n by n - upper triangular part of the array A must contain the upper - triangular matrix and the strictly lower triangular part of - A is not referenced. - Before entry with UPLO = 'L' or 'l', the leading n by n - lower triangular part of the array A must contain the lower - triangular matrix and the strictly upper triangular part of - A is not referenced. - Note that when DIAG = 'U' or 'u', the diagonal elements of - A are not referenced either, but are assumed to be unity. - Unchanged on exit. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. LDA must be at least - max( 1, n ). - Unchanged on exit. - X - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCX ) ). - Before entry, the incremented array X must contain the n - element vector x. On exit, X is overwritten with the - tranformed vector x. - INCX - INTEGER. - On entry, INCX specifies the increment for the elements of - X. INCX must not be zero. - Unchanged on exit. - Level 2 Blas routine. - -- Written on 22-October-1986. - Jack Dongarra, Argonne National Lab. - Jeremy Du Croz, Nag Central Office. - Sven Hammarling, Nag Central Office. - Richard Hanson, Sandia National Labs. - Test the input parameters. - Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --x; - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*lda < max(1,*n)) { - info = 6; - } else if (*incx == 0) { - info = 8; - } - if (info != 0) { - xerbla_("DTRMV ", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0) { - return 0; - } - nounit = lsame_(diag, "N"); -/* Set up the start point in X if the increment is not unity. This - will be ( N - 1 )*INCX too small for descending loops. */ - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } -/* Start the operations. In this version the elements of A are - accessed sequentially with one pass through A. */ - if (lsame_(trans, "N")) { -/* Form x := A*x. */ - if (lsame_(uplo, "U")) { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - temp = x[j]; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - x[i__] += temp * a_ref(i__, j); -/* L10: */ - } - if (nounit) { - x[j] *= a_ref(j, j); - } - } -/* L20: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - x[ix] += temp * a_ref(i__, j); - ix += *incx; -/* L30: */ - } - if (nounit) { - x[jx] *= a_ref(j, j); - } - } - jx += *incx; -/* L40: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.) { - temp = x[j]; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - x[i__] += temp * a_ref(i__, j); -/* L50: */ - } - if (nounit) { - x[j] *= a_ref(j, j); - } - } -/* L60: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - if (x[jx] != 0.) { - temp = x[jx]; - ix = kx; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - x[ix] += temp * a_ref(i__, j); - ix -= *incx; -/* L70: */ - } - if (nounit) { - x[jx] *= a_ref(j, j); - } - } - jx -= *incx; -/* L80: */ - } - } - } - } else { -/* Form x := A'*x. */ - if (lsame_(uplo, "U")) { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - if (nounit) { - temp *= a_ref(j, j); - } - for (i__ = j - 1; i__ >= 1; --i__) { - temp += a_ref(i__, j) * x[i__]; -/* L90: */ - } - x[j] = temp; -/* L100: */ - } - } else { - jx = kx + (*n - 1) * *incx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - ix = jx; - if (nounit) { - temp *= a_ref(j, j); - } - for (i__ = j - 1; i__ >= 1; --i__) { - ix -= *incx; - temp += a_ref(i__, j) * x[ix]; -/* L110: */ - } - x[jx] = temp; - jx -= *incx; -/* L120: */ - } - } - } else { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[j]; - if (nounit) { - temp *= a_ref(j, j); - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - temp += a_ref(i__, j) * x[i__]; -/* L130: */ - } - x[j] = temp; -/* L140: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[jx]; - ix = jx; - if (nounit) { - temp *= a_ref(j, j); - } - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - temp += a_ref(i__, j) * x[ix]; -/* L150: */ - } - x[jx] = temp; - jx += *incx; -/* L160: */ - } - } - } - } - return 0; -/* End of DTRMV . */ -} /* dtrmv_ */ -#undef a_ref - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/dtrsm.c b/ext/f2c_blas/dtrsm.c deleted file mode 100644 index 91e8e5a71..000000000 --- a/ext/f2c_blas/dtrsm.c +++ /dev/null @@ -1,410 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dtrsm_(char *side, char *uplo, char *transa, char *diag, - integer *m, integer *n, doublereal *alpha, doublereal *a, integer * - lda, doublereal *b, integer *ldb) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; - /* Local variables */ - static integer info; - static doublereal temp; - static integer i__, j, k; - static logical lside; - extern logical lsame_(char *, char *); - static integer nrowa; - static logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *); - static logical nounit; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] -/* Purpose - ======= - DTRSM solves one of the matrix equations - op( A )*X = alpha*B, or X*op( A ) = alpha*B, - where alpha is a scalar, X and B are m by n matrices, A is a unit, or - non-unit, upper or lower triangular matrix and op( A ) is one of - op( A ) = A or op( A ) = A'. - The matrix X is overwritten on B. - Parameters - ========== - SIDE - CHARACTER*1. - On entry, SIDE specifies whether op( A ) appears on the left - or right of X as follows: - SIDE = 'L' or 'l' op( A )*X = alpha*B. - SIDE = 'R' or 'r' X*op( A ) = alpha*B. - Unchanged on exit. - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the matrix A is an upper or - lower triangular matrix as follows: - UPLO = 'U' or 'u' A is an upper triangular matrix. - UPLO = 'L' or 'l' A is a lower triangular matrix. - Unchanged on exit. - TRANSA - CHARACTER*1. - On entry, TRANSA specifies the form of op( A ) to be used in - the matrix multiplication as follows: - TRANSA = 'N' or 'n' op( A ) = A. - TRANSA = 'T' or 't' op( A ) = A'. - TRANSA = 'C' or 'c' op( A ) = A'. - Unchanged on exit. - DIAG - CHARACTER*1. - On entry, DIAG specifies whether or not A is unit triangular - as follows: - DIAG = 'U' or 'u' A is assumed to be unit triangular. - DIAG = 'N' or 'n' A is not assumed to be unit - triangular. - Unchanged on exit. - M - INTEGER. - On entry, M specifies the number of rows of B. M must be at - least zero. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the number of columns of B. N must be - at least zero. - Unchanged on exit. - ALPHA - DOUBLE PRECISION. - On entry, ALPHA specifies the scalar alpha. When alpha is - zero then A is not referenced and B need not be set before - entry. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m - when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. - Before entry with UPLO = 'U' or 'u', the leading k by k - upper triangular part of the array A must contain the upper - triangular matrix and the strictly lower triangular part of - A is not referenced. - Before entry with UPLO = 'L' or 'l', the leading k by k - lower triangular part of the array A must contain the lower - triangular matrix and the strictly upper triangular part of - A is not referenced. - Note that when DIAG = 'U' or 'u', the diagonal elements of - A are not referenced either, but are assumed to be unity. - Unchanged on exit. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. When SIDE = 'L' or 'l' then - LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' - then LDA must be at least max( 1, n ). - Unchanged on exit. - B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). - Before entry, the leading m by n part of the array B must - contain the right-hand side matrix B, and on exit is - overwritten by the solution matrix X. - LDB - INTEGER. - On entry, LDB specifies the first dimension of B as declared - in the calling (sub) program. LDB must be at least - max( 1, m ). - Unchanged on exit. - Level 3 Blas routine. - -- Written on 8-February-1989. - Jack Dongarra, Argonne National Laboratory. - Iain Duff, AERE Harwell. - Jeremy Du Croz, Numerical Algorithms Group Ltd. - Sven Hammarling, Numerical Algorithms Group Ltd. - Test the input parameters. - Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - /* Function Body */ - lside = lsame_(side, "L"); - if (lside) { - nrowa = *m; - } else { - nrowa = *n; - } - nounit = lsame_(diag, "N"); - upper = lsame_(uplo, "U"); - info = 0; - if (! lside && ! lsame_(side, "R")) { - info = 1; - } else if (! upper && ! lsame_(uplo, "L")) { - info = 2; - } else if (! lsame_(transa, "N") && ! lsame_(transa, - "T") && ! lsame_(transa, "C")) { - info = 3; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 4; - } else if (*m < 0) { - info = 5; - } else if (*n < 0) { - info = 6; - } else if (*lda < max(1,nrowa)) { - info = 9; - } else if (*ldb < max(1,*m)) { - info = 11; - } - if (info != 0) { - xerbla_("DTRSM ", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0) { - return 0; - } -/* And when alpha.eq.zero. */ - if (*alpha == 0.) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = 0.; -/* L10: */ - } -/* L20: */ - } - return 0; - } -/* Start the operations. */ - if (lside) { - if (lsame_(transa, "N")) { -/* Form B := alpha*inv( A )*B. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = *alpha * b_ref(i__, j); -/* L30: */ - } - } - for (k = *m; k >= 1; --k) { - if (b_ref(k, j) != 0.) { - if (nounit) { - b_ref(k, j) = b_ref(k, j) / a_ref(k, k); - } - i__2 = k - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = b_ref(i__, j) - b_ref(k, j) * - a_ref(i__, k); -/* L40: */ - } - } -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = *alpha * b_ref(i__, j); -/* L70: */ - } - } - i__2 = *m; - for (k = 1; k <= i__2; ++k) { - if (b_ref(k, j) != 0.) { - if (nounit) { - b_ref(k, j) = b_ref(k, j) / a_ref(k, k); - } - i__3 = *m; - for (i__ = k + 1; i__ <= i__3; ++i__) { - b_ref(i__, j) = b_ref(i__, j) - b_ref(k, j) * - a_ref(i__, k); -/* L80: */ - } - } -/* L90: */ - } -/* L100: */ - } - } - } else { -/* Form B := alpha*inv( A' )*B. */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = *alpha * b_ref(i__, j); - i__3 = i__ - 1; - for (k = 1; k <= i__3; ++k) { - temp -= a_ref(k, i__) * b_ref(k, j); -/* L110: */ - } - if (nounit) { - temp /= a_ref(i__, i__); - } - b_ref(i__, j) = temp; -/* L120: */ - } -/* L130: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - for (i__ = *m; i__ >= 1; --i__) { - temp = *alpha * b_ref(i__, j); - i__2 = *m; - for (k = i__ + 1; k <= i__2; ++k) { - temp -= a_ref(k, i__) * b_ref(k, j); -/* L140: */ - } - if (nounit) { - temp /= a_ref(i__, i__); - } - b_ref(i__, j) = temp; -/* L150: */ - } -/* L160: */ - } - } - } - } else { - if (lsame_(transa, "N")) { -/* Form B := alpha*B*inv( A ). */ - if (upper) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (*alpha != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = *alpha * b_ref(i__, j); -/* L170: */ - } - } - i__2 = j - 1; - for (k = 1; k <= i__2; ++k) { - if (a_ref(k, j) != 0.) { - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b_ref(i__, j) = b_ref(i__, j) - a_ref(k, j) * - b_ref(i__, k); -/* L180: */ - } - } -/* L190: */ - } - if (nounit) { - temp = 1. / a_ref(j, j); - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = temp * b_ref(i__, j); -/* L200: */ - } - } -/* L210: */ - } - } else { - for (j = *n; j >= 1; --j) { - if (*alpha != 1.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b_ref(i__, j) = *alpha * b_ref(i__, j); -/* L220: */ - } - } - i__1 = *n; - for (k = j + 1; k <= i__1; ++k) { - if (a_ref(k, j) != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = b_ref(i__, j) - a_ref(k, j) * - b_ref(i__, k); -/* L230: */ - } - } -/* L240: */ - } - if (nounit) { - temp = 1. / a_ref(j, j); - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b_ref(i__, j) = temp * b_ref(i__, j); -/* L250: */ - } - } -/* L260: */ - } - } - } else { -/* Form B := alpha*B*inv( A' ). */ - if (upper) { - for (k = *n; k >= 1; --k) { - if (nounit) { - temp = 1. / a_ref(k, k); - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b_ref(i__, k) = temp * b_ref(i__, k); -/* L270: */ - } - } - i__1 = k - 1; - for (j = 1; j <= i__1; ++j) { - if (a_ref(j, k) != 0.) { - temp = a_ref(j, k); - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = b_ref(i__, j) - temp * b_ref( - i__, k); -/* L280: */ - } - } -/* L290: */ - } - if (*alpha != 1.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - b_ref(i__, k) = *alpha * b_ref(i__, k); -/* L300: */ - } - } -/* L310: */ - } - } else { - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (nounit) { - temp = 1. / a_ref(k, k); - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, k) = temp * b_ref(i__, k); -/* L320: */ - } - } - i__2 = *n; - for (j = k + 1; j <= i__2; ++j) { - if (a_ref(j, k) != 0.) { - temp = a_ref(j, k); - i__3 = *m; - for (i__ = 1; i__ <= i__3; ++i__) { - b_ref(i__, j) = b_ref(i__, j) - temp * b_ref( - i__, k); -/* L330: */ - } - } -/* L340: */ - } - if (*alpha != 1.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, k) = *alpha * b_ref(i__, k); -/* L350: */ - } - } -/* L360: */ - } - } - } - } - return 0; -/* End of DTRSM . */ -} /* dtrsm_ */ -#undef b_ref -#undef a_ref - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/dtrsv.c b/ext/f2c_blas/dtrsv.c deleted file mode 100644 index 0e706488a..000000000 --- a/ext/f2c_blas/dtrsv.c +++ /dev/null @@ -1,285 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dtrsv_(char *uplo, char *trans, char *diag, integer *n, - doublereal *a, integer *lda, doublereal *x, integer *incx) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - /* Local variables */ - static integer info; - static doublereal temp; - static integer i__, j; - extern logical lsame_(char *, char *); - static integer ix, jx, kx; - extern /* Subroutine */ int xerbla_(char *, integer *); - static logical nounit; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -/* Purpose - ======= - DTRSV solves one of the systems of equations - A*x = b, or A'*x = b, - where b and x are n element vectors and A is an n by n unit, or - non-unit, upper or lower triangular matrix. - No test for singularity or near-singularity is included in this - routine. Such tests must be performed before calling this routine. - Parameters - ========== - UPLO - CHARACTER*1. - On entry, UPLO specifies whether the matrix is an upper or - lower triangular matrix as follows: - UPLO = 'U' or 'u' A is an upper triangular matrix. - UPLO = 'L' or 'l' A is a lower triangular matrix. - Unchanged on exit. - TRANS - CHARACTER*1. - On entry, TRANS specifies the equations to be solved as - follows: - TRANS = 'N' or 'n' A*x = b. - TRANS = 'T' or 't' A'*x = b. - TRANS = 'C' or 'c' A'*x = b. - Unchanged on exit. - DIAG - CHARACTER*1. - On entry, DIAG specifies whether or not A is unit - triangular as follows: - DIAG = 'U' or 'u' A is assumed to be unit triangular. - DIAG = 'N' or 'n' A is not assumed to be unit - triangular. - Unchanged on exit. - N - INTEGER. - On entry, N specifies the order of the matrix A. - N must be at least zero. - Unchanged on exit. - A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). - Before entry with UPLO = 'U' or 'u', the leading n by n - upper triangular part of the array A must contain the upper - triangular matrix and the strictly lower triangular part of - A is not referenced. - Before entry with UPLO = 'L' or 'l', the leading n by n - lower triangular part of the array A must contain the lower - triangular matrix and the strictly upper triangular part of - A is not referenced. - Note that when DIAG = 'U' or 'u', the diagonal elements of - A are not referenced either, but are assumed to be unity. - Unchanged on exit. - LDA - INTEGER. - On entry, LDA specifies the first dimension of A as declared - in the calling (sub) program. LDA must be at least - max( 1, n ). - Unchanged on exit. - X - DOUBLE PRECISION array of dimension at least - ( 1 + ( n - 1 )*abs( INCX ) ). - Before entry, the incremented array X must contain the n - element right-hand side vector b. On exit, X is overwritten - with the solution vector x. - INCX - INTEGER. - On entry, INCX specifies the increment for the elements of - X. INCX must not be zero. - Unchanged on exit. - Level 2 Blas routine. - -- Written on 22-October-1986. - Jack Dongarra, Argonne National Lab. - Jeremy Du Croz, Nag Central Office. - Sven Hammarling, Nag Central Office. - Richard Hanson, Sandia National Labs. - Test the input parameters. - Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --x; - /* Function Body */ - info = 0; - if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { - info = 1; - } else if (! lsame_(trans, "N") && ! lsame_(trans, - "T") && ! lsame_(trans, "C")) { - info = 2; - } else if (! lsame_(diag, "U") && ! lsame_(diag, - "N")) { - info = 3; - } else if (*n < 0) { - info = 4; - } else if (*lda < max(1,*n)) { - info = 6; - } else if (*incx == 0) { - info = 8; - } - if (info != 0) { - xerbla_("DTRSV ", &info); - return 0; - } -/* Quick return if possible. */ - if (*n == 0) { - return 0; - } - nounit = lsame_(diag, "N"); -/* Set up the start point in X if the increment is not unity. This - will be ( N - 1 )*INCX too small for descending loops. */ - if (*incx <= 0) { - kx = 1 - (*n - 1) * *incx; - } else if (*incx != 1) { - kx = 1; - } -/* Start the operations. In this version the elements of A are - accessed sequentially with one pass through A. */ - if (lsame_(trans, "N")) { -/* Form x := inv( A )*x. */ - if (lsame_(uplo, "U")) { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - if (x[j] != 0.) { - if (nounit) { - x[j] /= a_ref(j, j); - } - temp = x[j]; - for (i__ = j - 1; i__ >= 1; --i__) { - x[i__] -= temp * a_ref(i__, j); -/* L10: */ - } - } -/* L20: */ - } - } else { - jx = kx + (*n - 1) * *incx; - for (j = *n; j >= 1; --j) { - if (x[jx] != 0.) { - if (nounit) { - x[jx] /= a_ref(j, j); - } - temp = x[jx]; - ix = jx; - for (i__ = j - 1; i__ >= 1; --i__) { - ix -= *incx; - x[ix] -= temp * a_ref(i__, j); -/* L30: */ - } - } - jx -= *incx; -/* L40: */ - } - } - } else { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[j] != 0.) { - if (nounit) { - x[j] /= a_ref(j, j); - } - temp = x[j]; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - x[i__] -= temp * a_ref(i__, j); -/* L50: */ - } - } -/* L60: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (x[jx] != 0.) { - if (nounit) { - x[jx] /= a_ref(j, j); - } - temp = x[jx]; - ix = jx; - i__2 = *n; - for (i__ = j + 1; i__ <= i__2; ++i__) { - ix += *incx; - x[ix] -= temp * a_ref(i__, j); -/* L70: */ - } - } - jx += *incx; -/* L80: */ - } - } - } - } else { -/* Form x := inv( A' )*x. */ - if (lsame_(uplo, "U")) { - if (*incx == 1) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[j]; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - temp -= a_ref(i__, j) * x[i__]; -/* L90: */ - } - if (nounit) { - temp /= a_ref(j, j); - } - x[j] = temp; -/* L100: */ - } - } else { - jx = kx; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - temp = x[jx]; - ix = kx; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - temp -= a_ref(i__, j) * x[ix]; - ix += *incx; -/* L110: */ - } - if (nounit) { - temp /= a_ref(j, j); - } - x[jx] = temp; - jx += *incx; -/* L120: */ - } - } - } else { - if (*incx == 1) { - for (j = *n; j >= 1; --j) { - temp = x[j]; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - temp -= a_ref(i__, j) * x[i__]; -/* L130: */ - } - if (nounit) { - temp /= a_ref(j, j); - } - x[j] = temp; -/* L140: */ - } - } else { - kx += (*n - 1) * *incx; - jx = kx; - for (j = *n; j >= 1; --j) { - temp = x[jx]; - ix = kx; - i__1 = j + 1; - for (i__ = *n; i__ >= i__1; --i__) { - temp -= a_ref(i__, j) * x[ix]; - ix -= *incx; -/* L150: */ - } - if (nounit) { - temp /= a_ref(j, j); - } - x[jx] = temp; - jx -= *incx; -/* L160: */ - } - } - } - } - return 0; -/* End of DTRSV . */ -} /* dtrsv_ */ -#undef a_ref - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/dzasum.c b/ext/f2c_blas/dzasum.c deleted file mode 100644 index 68780bcd6..000000000 --- a/ext/f2c_blas/dzasum.c +++ /dev/null @@ -1,55 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -doublereal dzasum_(integer *n, doublecomplex *zx, integer *incx) -{ - /* System generated locals */ - integer i__1; - doublereal ret_val; - /* Local variables */ - static integer i__; - static doublereal stemp; - extern doublereal dcabs1_(doublecomplex *); - static integer ix; -/* takes the sum of the absolute values. - jack dongarra, 3/11/78. - modified 3/93 to return if incx .le. 0. - modified 12/3/93, array(1) declarations changed to array(*) - Parameter adjustments */ - --zx; - /* Function Body */ - ret_val = 0.; - stemp = 0.; - if (*n <= 0 || *incx <= 0) { - return ret_val; - } - if (*incx == 1) { - goto L20; - } -/* code for increment not equal to 1 */ - ix = 1; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - stemp += dcabs1_(&zx[ix]); - ix += *incx; -/* L10: */ - } - ret_val = stemp; - return ret_val; -/* code for increment equal to 1 */ -L20: - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - stemp += dcabs1_(&zx[i__]); -/* L30: */ - } - ret_val = stemp; - return ret_val; -} /* dzasum_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/dznrm2.c b/ext/f2c_blas/dznrm2.c deleted file mode 100644 index 627409068..000000000 --- a/ext/f2c_blas/dznrm2.c +++ /dev/null @@ -1,82 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -doublereal dznrm2_(integer *n, doublecomplex *x, integer *incx) -{ -/* The following loop is equivalent to this call to the LAPACK - auxiliary routine: - CALL ZLASSQ( N, X, INCX, SCALE, SSQ ) */ - /* System generated locals */ - integer i__1, i__2, i__3; - doublereal ret_val, d__1; - /* Builtin functions */ - double d_imag(doublecomplex *), sqrt(doublereal); - /* Local variables */ - static doublereal temp, norm, scale; - static integer ix; - static doublereal ssq; -/* DZNRM2 returns the euclidean norm of a vector via the function - name, so that - DZNRM2 := sqrt( conjg( x' )*x ) - -- This version written on 25-October-1982. - Modified on 14-October-1993 to inline the call to ZLASSQ. - Sven Hammarling, Nag Ltd. - Parameter adjustments */ - --x; - /* Function Body */ - if (*n < 1 || *incx < 1) { - norm = 0.; - } else { - scale = 0.; - ssq = 1.; - - - i__1 = (*n - 1) * *incx + 1; - i__2 = *incx; - for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { - i__3 = ix; - if (x[i__3].r != 0.) { - i__3 = ix; - temp = (d__1 = x[i__3].r, abs(d__1)); - if (scale < temp) { -/* Computing 2nd power */ - d__1 = scale / temp; - ssq = ssq * (d__1 * d__1) + 1.; - scale = temp; - } else { -/* Computing 2nd power */ - d__1 = temp / scale; - ssq += d__1 * d__1; - } - } - if (d_imag(&x[ix]) != 0.) { - temp = (d__1 = d_imag(&x[ix]), abs(d__1)); - if (scale < temp) { -/* Computing 2nd power */ - d__1 = scale / temp; - ssq = ssq * (d__1 * d__1) + 1.; - scale = temp; - } else { -/* Computing 2nd power */ - d__1 = temp / scale; - ssq += d__1 * d__1; - } - } -/* L10: */ - } - norm = scale * sqrt(ssq); - } - - ret_val = norm; - return ret_val; - -/* End of DZNRM2. */ - -} /* dznrm2_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/idamax.c b/ext/f2c_blas/idamax.c deleted file mode 100644 index c64ea8427..000000000 --- a/ext/f2c_blas/idamax.c +++ /dev/null @@ -1,74 +0,0 @@ -/* idamax.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -integer idamax_(integer *n, doublereal *dx, integer *incx) -{ - /* System generated locals */ - integer ret_val, i__1; - doublereal d__1; - - /* Local variables */ - integer i__, ix; - doublereal dmax__; - - -/* finds the index of element having max. absolute value. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified 3/93 to return if incx .le. 0. */ - - - /* Parameter adjustments */ - --dx; - - /* Function Body */ - ret_val = 0; - if (*n < 1 || *incx <= 0) { - return ret_val; - } - ret_val = 1; - if (*n == 1) { - return ret_val; - } - if (*incx == 1) { - goto L20; - } - -/* code for increment not equal to 1 */ - - ix = 1; - dmax__ = abs(dx[1]); - ix += *incx; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - if ((d__1 = dx[ix], abs(d__1)) <= dmax__) { - goto L5; - } - ret_val = i__; - dmax__ = (d__1 = dx[ix], abs(d__1)); -L5: - ix += *incx; -/* L10: */ - } - return ret_val; - -/* code for increment equal to 1 */ - -L20: - dmax__ = abs(dx[1]); - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - if ((d__1 = dx[i__], abs(d__1)) <= dmax__) { - goto L30; - } - ret_val = i__; - dmax__ = (d__1 = dx[i__], abs(d__1)); -L30: - ; - } - return ret_val; -} /* idamax_ */ - diff --git a/ext/f2c_blas/isamax.c b/ext/f2c_blas/isamax.c deleted file mode 100644 index 2d3400b30..000000000 --- a/ext/f2c_blas/isamax.c +++ /dev/null @@ -1,88 +0,0 @@ -/* isamax.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#ifdef __cplusplus -extern "C" { -#endif -#include "f2c.h" - -integer isamax_(integer *n, real *sx, integer *incx) -{ - /* System generated locals */ - integer ret_val, i__1; - real r__1; - - /* Local variables */ - static integer i__, ix; - static real smax; - - -/* finds the index of element having max. absolute value. */ -/* jack dongarra, linpack, 3/11/78. */ -/* modified 3/93 to return if incx .le. 0. */ -/* modified 12/3/93, array(1) declarations changed to array(*) */ - - - /* Parameter adjustments */ - --sx; - - /* Function Body */ - ret_val = 0; - if (*n < 1 || *incx <= 0) { - return ret_val; - } - ret_val = 1; - if (*n == 1) { - return ret_val; - } - if (*incx == 1) { - goto L20; - } - -/* code for increment not equal to 1 */ - - ix = 1; - smax = (real) dabs(sx[1]); - ix += *incx; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - if ((r__1 = sx[ix], dabs(r__1)) <= smax) { - goto L5; - } - ret_val = i__; - smax = (real) (r__1 = sx[ix], dabs(r__1)); -L5: - ix += *incx; -/* L10: */ - } - return ret_val; - -/* code for increment equal to 1 */ - -L20: - smax = (real) dabs(sx[1]); - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - if ((r__1 = sx[i__], dabs(r__1)) <= smax) { - goto L30; - } - ret_val = i__; - smax = (real) (r__1 = sx[i__], dabs(r__1)); -L30: - ; - } - return ret_val; -} /* isamax_ */ - -#ifdef __cplusplus - } -#endif diff --git a/ext/f2c_blas/lsame.c b/ext/f2c_blas/lsame.c deleted file mode 100644 index ba8740b44..000000000 --- a/ext/f2c_blas/lsame.c +++ /dev/null @@ -1,107 +0,0 @@ -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -logical lsame_(char *ca, char *cb) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - September 30, 1994 - - - Purpose - ======= - - LSAME returns .TRUE. if CA is the same letter as CB regardless of - case. - - Arguments - ========= - - CA (input) CHARACTER*1 - CB (input) CHARACTER*1 - CA and CB specify the single characters to be compared. - - ===================================================================== - - - - Test if the characters are equal */ - /* System generated locals */ - logical ret_val; - /* Local variables */ - static integer inta, intb, zcode; - - - ret_val = *(unsigned char *)ca == *(unsigned char *)cb; - if (ret_val) { - return ret_val; - } - -/* Now test for equivalence if both characters are alphabetic. */ - - zcode = 'Z'; - -/* Use 'Z' rather than 'A' so that ASCII can be detected on Prime - machines, on which ICHAR returns a value with bit 8 set. - ICHAR('A') on Prime machines returns 193 which is the same as - ICHAR('A') on an EBCDIC machine. */ - - inta = *(unsigned char *)ca; - intb = *(unsigned char *)cb; - - if (zcode == 90 || zcode == 122) { - -/* ASCII is assumed - ZCODE is the ASCII code of either lower o -r - upper case 'Z'. */ - - if (inta >= 97 && inta <= 122) { - inta += -32; - } - if (intb >= 97 && intb <= 122) { - intb += -32; - } - - } else if (zcode == 233 || zcode == 169) { - -/* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower - or - upper case 'Z'. */ - - if (inta >= 129 && inta <= 137 || inta >= 145 && inta <= 153 || inta - >= 162 && inta <= 169) { - inta += 64; - } - if (intb >= 129 && intb <= 137 || intb >= 145 && intb <= 153 || intb - >= 162 && intb <= 169) { - intb += 64; - } - - } else if (zcode == 218 || zcode == 250) { - -/* ASCII is assumed, on Prime machines - ZCODE is the ASCII cod -e - plus 128 of either lower or upper case 'Z'. */ - - if (inta >= 225 && inta <= 250) { - inta += -32; - } - if (intb >= 225 && intb <= 250) { - intb += -32; - } - } - ret_val = inta == intb; - -/* RETURN - - End of LSAME */ - - return ret_val; -} /* lsame_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_blas/xerbla.c b/ext/f2c_blas/xerbla.c deleted file mode 100644 index 7a70bd8bb..000000000 --- a/ext/f2c_blas/xerbla.c +++ /dev/null @@ -1,50 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" -#include "stdio.h" - -/* Subroutine */ int xerbla_(char *srname, integer *info) -{ -/* -- LAPACK auxiliary routine (version 2.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - September 30, 1994 - - - Purpose - ======= - - XERBLA is an error handler for the LAPACK routines. - It is called by an LAPACK routine if an input parameter has an - invalid value. A message is printed and execution stops. - - Installers may consider modifying the STOP statement in order to - call system-specific exception-handling facilities. - - Arguments - ========= - - SRNAME (input) CHARACTER*6 - The name of the routine which called XERBLA. - - INFO (input) INTEGER - The position of the invalid parameter in the parameter list - - of the calling routine. - - ===================================================================== -*/ - - printf("** On entry to %6s, parameter number %2i had an illegal value\n", - srname, *info); - -/* End of XERBLA */ - - return 0; -} /* xerbla_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/blaswrap.h b/ext/f2c_lapack/blaswrap.h deleted file mode 100644 index 7d95f3c52..000000000 --- a/ext/f2c_lapack/blaswrap.h +++ /dev/null @@ -1,159 +0,0 @@ -/* CLAPACK 3.0 BLAS wrapper macros - * Feb 5, 2000 - */ - -#ifndef __BLASWRAP_H -#define __BLASWRAP_H - -#define NO_BLAS_WRAP -#ifndef NO_BLAS_WRAP - -/* BLAS1 routines */ -#define srotg_ f2c_srotg -#define drotg_ f2c_drotg -#define srotmg_ f2c_srotmg -#define drotmg_ f2c_drotmg -#define srot_ f2c_srot -#define drot_ f2c_drot -#define srotm_ f2c_srotm -#define drotm_ f2c_drotm -#define sswap_ f2c_sswap -#define dswap_ f2c_dswap -#define cswap_ f2c_cswap -#define zswap_ f2c_zswap -#define sscal_ f2c_sscal -#define dscal_ f2c_dscal -#define cscal_ f2c_cscal -#define zscal_ f2c_zscal -#define csscal_ f2c_csscal -#define zdscal_ f2c_zdscal -#define scopy_ f2c_scopy -#define dcopy_ f2c_dcopy -#define ccopy_ f2c_ccopy -#define zcopy_ f2c_zcopy -#define saxpy_ f2c_saxpy -#define daxpy_ f2c_daxpy -#define caxpy_ f2c_caxpy -#define zaxpy_ f2c_zaxpy -#define sdot_ f2c_sdot -#define ddot_ f2c_ddot -#define cdotu_ f2c_cdotu -#define zdotu_ f2c_zdotu -#define cdotc_ f2c_cdotc -#define zdotc_ f2c_zdotc -#define snrm2_ f2c_snrm2 -#define dnrm2_ f2c_dnrm2 -#define scnrm2_ f2c_scnrm2 -#define dznrm2_ f2c_dznrm2 -#define sasum_ f2c_sasum -#define dasum_ f2c_dasum -#define scasum_ f2c_scasum -#define dzasum_ f2c_dzasum -#define isamax_ f2c_isamax -#define idamax_ f2c_idamax -#define icamax_ f2c_icamax -#define izamax_ f2c_izamax - -/* BLAS2 routines */ -#define sgemv_ f2c_sgemv -#define dgemv_ f2c_dgemv -#define cgemv_ f2c_cgemv -#define zgemv_ f2c_zgemv -#define sgbmv_ f2c_sgbmv -#define dgbmv_ f2c_dgbmv -#define cgbmv_ f2c_cgbmv -#define zgbmv_ f2c_zgbmv -#define chemv_ f2c_chemv -#define zhemv_ f2c_zhemv -#define chbmv_ f2c_chbmv -#define zhbmv_ f2c_zhbmv -#define chpmv_ f2c_chpmv -#define zhpmv_ f2c_zhpmv -#define ssymv_ f2c_ssymv -#define dsymv_ f2c_dsymv -#define ssbmv_ f2c_ssbmv -#define dsbmv_ f2c_dsbmv -#define sspmv_ f2c_sspmv -#define dspmv_ f2c_dspmv -#define strmv_ f2c_strmv -#define dtrmv_ f2c_dtrmv -#define ctrmv_ f2c_ctrmv -#define ztrmv_ f2c_ztrmv -#define stbmv_ f2c_stbmv -#define dtbmv_ f2c_dtbmv -#define ctbmv_ f2c_ctbmv -#define ztbmv_ f2c_ztbmv -#define stpmv_ f2c_stpmv -#define dtpmv_ f2c_dtpmv -#define ctpmv_ f2c_ctpmv -#define ztpmv_ f2c_ztpmv -#define strsv_ f2c_strsv -#define dtrsv_ f2c_dtrsv -#define ctrsv_ f2c_ctrsv -#define ztrsv_ f2c_ztrsv -#define stbsv_ f2c_stbsv -#define dtbsv_ f2c_dtbsv -#define ctbsv_ f2c_ctbsv -#define ztbsv_ f2c_ztbsv -#define stpsv_ f2c_stpsv -#define dtpsv_ f2c_dtpsv -#define ctpsv_ f2c_ctpsv -#define ztpsv_ f2c_ztpsv -#define sger_ f2c_sger -#define dger_ f2c_dger -#define cgeru_ f2c_cgeru -#define zgeru_ f2c_zgeru -#define cgerc_ f2c_cgerc -#define zgerc_ f2c_zgerc -#define cher_ f2c_cher -#define zher_ f2c_zher -#define chpr_ f2c_chpr -#define zhpr_ f2c_zhpr -#define cher2_ f2c_cher2 -#define zher2_ f2c_zher2 -#define chpr2_ f2c_chpr2 -#define zhpr2_ f2c_zhpr2 -#define ssyr_ f2c_ssyr -#define dsyr_ f2c_dsyr -#define sspr_ f2c_sspr -#define dspr_ f2c_dspr -#define ssyr2_ f2c_ssyr2 -#define dsyr2_ f2c_dsyr2 -#define sspr2_ f2c_sspr2 -#define dspr2_ f2c_dspr2 - -/* BLAS3 routines */ -#define sgemm_ f2c_sgemm -#define dgemm_ f2c_dgemm -#define cgemm_ f2c_cgemm -#define zgemm_ f2c_zgemm -#define ssymm_ f2c_ssymm -#define dsymm_ f2c_dsymm -#define csymm_ f2c_csymm -#define zsymm_ f2c_zsymm -#define chemm_ f2c_chemm -#define zhemm_ f2c_zhemm -#define ssyrk_ f2c_ssyrk -#define dsyrk_ f2c_dsyrk -#define csyrk_ f2c_csyrk -#define zsyrk_ f2c_zsyrk -#define cherk_ f2c_cherk -#define zherk_ f2c_zherk -#define ssyr2k_ f2c_ssyr2k -#define dsyr2k_ f2c_dsyr2k -#define csyr2k_ f2c_csyr2k -#define zsyr2k_ f2c_zsyr2k -#define cher2k_ f2c_cher2k -#define zher2k_ f2c_zher2k -#define strmm_ f2c_strmm -#define dtrmm_ f2c_dtrmm -#define ctrmm_ f2c_ctrmm -#define ztrmm_ f2c_ztrmm -#define strsm_ f2c_strsm -#define dtrsm_ f2c_dtrsm -#define ctrsm_ f2c_ctrsm -#define ztrsm_ f2c_ztrsm - -#endif /* NO_BLAS_WRAP */ - -#endif /* __BLASWRAP_H */ diff --git a/ext/f2c_lapack/dbdsqr.c b/ext/f2c_lapack/dbdsqr.c deleted file mode 100644 index 494a9b76d..000000000 --- a/ext/f2c_lapack/dbdsqr.c +++ /dev/null @@ -1,906 +0,0 @@ -#include "blaswrap.h" -/* -- translated by f2c (version 19990503). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Table of constant values */ - -static doublereal c_b15 = -.125; -static integer c__1 = 1; -static doublereal c_b49 = 1.; -static doublereal c_b72 = -1.; - -/* Subroutine */ int dbdsqr_(char *uplo, integer *n, integer *ncvt, integer * - nru, integer *ncc, doublereal *d__, doublereal *e, doublereal *vt, - integer *ldvt, doublereal *u, integer *ldu, doublereal *c__, integer * - ldc, doublereal *work, integer *info) -{ - /* System generated locals */ - integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, - i__2; - doublereal d__1, d__2, d__3, d__4; - - /* Builtin functions */ - double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign( - doublereal *, doublereal *); - - /* Local variables */ - static doublereal abse; - static integer idir; - static doublereal abss; - static integer oldm; - static doublereal cosl; - static integer isub, iter; - static doublereal unfl, sinl, cosr, smin, smax, sinr; - extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, doublereal *), dlas2_( - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *); - static doublereal f, g, h__; - static integer i__, j, m; - static doublereal r__; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - extern logical lsame_(char *, char *); - static doublereal oldcs; - extern /* Subroutine */ int dlasr_(char *, char *, char *, integer *, - integer *, doublereal *, doublereal *, doublereal *, integer *); - static integer oldll; - static doublereal shift, sigmn, oldsn; - extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, - doublereal *, integer *); - static integer maxit; - static doublereal sminl, sigmx; - static logical lower; - extern /* Subroutine */ int dlasq1_(integer *, doublereal *, doublereal *, - doublereal *, integer *), dlasv2_(doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *); - static doublereal cs; - static integer ll; - extern doublereal dlamch_(char *); - static doublereal sn, mu; - extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *), xerbla_(char *, - integer *); - static doublereal sminoa, thresh; - static logical rotate; - static doublereal sminlo; - static integer nm1; - static doublereal tolmul; - static integer nm12, nm13, lll; - static doublereal eps, sll, tol; - - -#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] -#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1] -#define vt_ref(a_1,a_2) vt[(a_2)*vt_dim1 + a_1] - - -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1999 - - - Purpose - ======= - - DBDSQR computes the singular value decomposition (SVD) of a real - N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' - denotes the transpose of P), where S is a diagonal matrix with - non-negative diagonal elements (the singular values of B), and Q - and P are orthogonal matrices. - - The routine computes S, and optionally computes U * Q, P' * VT, - or Q' * C, for given real input matrices U, VT, and C. - - See "Computing Small Singular Values of Bidiagonal Matrices With - Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, - LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, - no. 5, pp. 873-912, Sept 1990) and - "Accurate singular values and differential qd algorithms," by - B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics - Department, University of California at Berkeley, July 1992 - for a detailed description of the algorithm. - - Arguments - ========= - - UPLO (input) CHARACTER*1 - = 'U': B is upper bidiagonal; - = 'L': B is lower bidiagonal. - - N (input) INTEGER - The order of the matrix B. N >= 0. - - NCVT (input) INTEGER - The number of columns of the matrix VT. NCVT >= 0. - - NRU (input) INTEGER - The number of rows of the matrix U. NRU >= 0. - - NCC (input) INTEGER - The number of columns of the matrix C. NCC >= 0. - - D (input/output) DOUBLE PRECISION array, dimension (N) - On entry, the n diagonal elements of the bidiagonal matrix B. - On exit, if INFO=0, the singular values of B in decreasing - order. - - E (input/output) DOUBLE PRECISION array, dimension (N) - On entry, the elements of E contain the - offdiagonal elements of the bidiagonal matrix whose SVD - is desired. On normal exit (INFO = 0), E is destroyed. - If the algorithm does not converge (INFO > 0), D and E - will contain the diagonal and superdiagonal elements of a - bidiagonal matrix orthogonally equivalent to the one given - as input. E(N) is used for workspace. - - VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) - On entry, an N-by-NCVT matrix VT. - On exit, VT is overwritten by P' * VT. - VT is not referenced if NCVT = 0. - - LDVT (input) INTEGER - The leading dimension of the array VT. - LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. - - U (input/output) DOUBLE PRECISION array, dimension (LDU, N) - On entry, an NRU-by-N matrix U. - On exit, U is overwritten by U * Q. - U is not referenced if NRU = 0. - - LDU (input) INTEGER - The leading dimension of the array U. LDU >= max(1,NRU). - - C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) - On entry, an N-by-NCC matrix C. - On exit, C is overwritten by Q' * C. - C is not referenced if NCC = 0. - - LDC (input) INTEGER - The leading dimension of the array C. - LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. - - WORK (workspace) DOUBLE PRECISION array, dimension (4*N) - - INFO (output) INTEGER - = 0: successful exit - < 0: If INFO = -i, the i-th argument had an illegal value - > 0: the algorithm did not converge; D and E contain the - elements of a bidiagonal matrix which is orthogonally - similar to the input matrix B; if INFO = i, i - elements of E have not converged to zero. - - Internal Parameters - =================== - - TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) - TOLMUL controls the convergence criterion of the QR loop. - If it is positive, TOLMUL*EPS is the desired relative - precision in the computed singular values. - If it is negative, abs(TOLMUL*EPS*sigma_max) is the - desired absolute accuracy in the computed singular - values (corresponds to relative accuracy - abs(TOLMUL*EPS) in the largest singular value. - abs(TOLMUL) should be between 1 and 1/EPS, and preferably - between 10 (for fast convergence) and .1/EPS - (for there to be some accuracy in the results). - Default is to lose at either one eighth or 2 of the - available decimal digits in each computed singular value - (whichever is smaller). - - MAXITR INTEGER, default = 6 - MAXITR controls the maximum number of passes of the - algorithm through its inner loop. The algorithms stops - (and so fails to converge) if the number of passes - through the inner loop exceeds MAXITR*N**2. - - ===================================================================== - - - Test the input parameters. - - Parameter adjustments */ - --d__; - --e; - vt_dim1 = *ldvt; - vt_offset = 1 + vt_dim1 * 1; - vt -= vt_offset; - u_dim1 = *ldu; - u_offset = 1 + u_dim1 * 1; - u -= u_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - lower = lsame_(uplo, "L"); - if (! lsame_(uplo, "U") && ! lower) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*ncvt < 0) { - *info = -3; - } else if (*nru < 0) { - *info = -4; - } else if (*ncc < 0) { - *info = -5; - } else if ((*ncvt == 0 && *ldvt < 1) || - (*ncvt > 0 && *ldvt < max(1,*n))) { - *info = -9; - } else if (*ldu < max(1,*nru)) { - *info = -11; - } else if ((*ncc == 0 && *ldc < 1) || - (*ncc > 0 && *ldc < max(1,*n))) { - *info = -13; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DBDSQR", &i__1); - return 0; - } - if (*n == 0) { - return 0; - } - if (*n == 1) { - goto L160; - } - -/* ROTATE is true if any singular vectors desired, false otherwise */ - - rotate = *ncvt > 0 || *nru > 0 || *ncc > 0; - -/* If no singular vectors desired, use qd algorithm */ - - if (! rotate) { - dlasq1_(n, &d__[1], &e[1], &work[1], info); - return 0; - } - - nm1 = *n - 1; - nm12 = nm1 + nm1; - nm13 = nm12 + nm1; - idir = 0; - -/* Get machine constants */ - - eps = dlamch_("Epsilon"); - unfl = dlamch_("Safe minimum"); - -/* If matrix lower bidiagonal, rotate to be upper bidiagonal - by applying Givens rotations on the left */ - - if (lower) { - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); - d__[i__] = r__; - e[i__] = sn * d__[i__ + 1]; - d__[i__ + 1] = cs * d__[i__ + 1]; - work[i__] = cs; - work[nm1 + i__] = sn; -/* L10: */ - } - -/* Update singular vectors if desired */ - - if (*nru > 0) { - dlasr_("R", "V", "F", nru, n, &work[1], &work[*n], &u[u_offset], - ldu); - } - if (*ncc > 0) { - dlasr_("L", "V", "F", n, ncc, &work[1], &work[*n], &c__[c_offset], - ldc); - } - } - -/* Compute singular values to relative accuracy TOL - (By setting TOL to be negative, algorithm will compute - singular values to absolute accuracy ABS(TOL)*norm(input matrix)) - - Computing MAX - Computing MIN */ - d__3 = 100., d__4 = pow_dd(&eps, &c_b15); - d__1 = 10., d__2 = min(d__3,d__4); - tolmul = max(d__1,d__2); - tol = tolmul * eps; - -/* Compute approximate maximum, minimum singular values */ - - smax = 0.; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1)); - smax = max(d__2,d__3); -/* L20: */ - } - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1)); - smax = max(d__2,d__3); -/* L30: */ - } - sminl = 0.; - if (tol >= 0.) { - -/* Relative accuracy desired */ - - sminoa = abs(d__[1]); - if (sminoa == 0.) { - goto L50; - } - mu = sminoa; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1] - , abs(d__1)))); - sminoa = min(sminoa,mu); - if (sminoa == 0.) { - goto L50; - } -/* L40: */ - } -L50: - sminoa /= sqrt((doublereal) (*n)); -/* Computing MAX */ - d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl; - thresh = max(d__1,d__2); - } else { - -/* Absolute accuracy desired - - Computing MAX */ - d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl; - thresh = max(d__1,d__2); - } - -/* Prepare for main iteration loop for the singular values - (MAXIT is the maximum number of passes through the inner - loop permitted before nonconvergence signalled.) */ - - maxit = *n * 6 * *n; - iter = 0; - oldll = -1; - oldm = -1; - -/* M points to last element of unconverged part of matrix */ - - m = *n; - -/* Begin main iteration loop */ - -L60: - -/* Check for convergence or exceeding iteration count */ - - if (m <= 1) { - goto L160; - } - if (iter > maxit) { - goto L200; - } - -/* Find diagonal block of matrix to work on */ - - if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) { - d__[m] = 0.; - } - smax = (d__1 = d__[m], abs(d__1)); - smin = smax; - i__1 = m - 1; - for (lll = 1; lll <= i__1; ++lll) { - ll = m - lll; - abss = (d__1 = d__[ll], abs(d__1)); - abse = (d__1 = e[ll], abs(d__1)); - if (tol < 0. && abss <= thresh) { - d__[ll] = 0.; - } - if (abse <= thresh) { - goto L80; - } - smin = min(smin,abss); -/* Computing MAX */ - d__1 = max(smax,abss); - smax = max(d__1,abse); -/* L70: */ - } - ll = 0; - goto L90; -L80: - e[ll] = 0.; - -/* Matrix splits since E(LL) = 0 */ - - if (ll == m - 1) { - -/* Convergence of bottom singular value, return to top of loop */ - - --m; - goto L60; - } -L90: - ++ll; - -/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */ - - if (ll == m - 1) { - -/* 2 by 2 block, handle separately */ - - dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr, - &sinl, &cosl); - d__[m - 1] = sigmx; - e[m - 1] = 0.; - d__[m] = sigmn; - -/* Compute singular vectors, if desired */ - - if (*ncvt > 0) { - drot_(ncvt, &vt_ref(m - 1, 1), ldvt, &vt_ref(m, 1), ldvt, &cosr, & - sinr); - } - if (*nru > 0) { - drot_(nru, &u_ref(1, m - 1), &c__1, &u_ref(1, m), &c__1, &cosl, & - sinl); - } - if (*ncc > 0) { - drot_(ncc, &c___ref(m - 1, 1), ldc, &c___ref(m, 1), ldc, &cosl, & - sinl); - } - m += -2; - goto L60; - } - -/* If working on new submatrix, choose shift direction - (from larger end diagonal element towards smaller) */ - - if (ll > oldm || m < oldll) { - if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) { - -/* Chase bulge from top (big end) to bottom (small end) */ - - idir = 1; - } else { - -/* Chase bulge from bottom (big end) to top (small end) */ - - idir = 2; - } - } - -/* Apply convergence tests */ - - if (idir == 1) { - -/* Run convergence test in forward direction - First apply standard test to bottom of matrix */ - - if (((d__2 = e[m - 1], abs(d__2)) <= - abs(tol) * (d__1 = d__[m], abs(d__1))) || - (tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh)) - { - e[m - 1] = 0.; - goto L60; - } - - if (tol >= 0.) { - -/* If relative accuracy desired, - apply convergence criterion forward */ - - mu = (d__1 = d__[ll], abs(d__1)); - sminl = mu; - i__1 = m - 1; - for (lll = ll; lll <= i__1; ++lll) { - if ((d__1 = e[lll], abs(d__1)) <= tol * mu) { - e[lll] = 0.; - goto L60; - } - sminlo = sminl; - mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[ - lll], abs(d__1)))); - sminl = min(sminl,mu); -/* L100: */ - } - } - - } else { - -/* Run convergence test in backward direction - First apply standard test to top of matrix */ - - if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1) - ) || - (tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh)) { - e[ll] = 0.; - goto L60; - } - - if (tol >= 0.) { - -/* If relative accuracy desired, - apply convergence criterion backward */ - - mu = (d__1 = d__[m], abs(d__1)); - sminl = mu; - i__1 = ll; - for (lll = m - 1; lll >= i__1; --lll) { - if ((d__1 = e[lll], abs(d__1)) <= tol * mu) { - e[lll] = 0.; - goto L60; - } - sminlo = sminl; - mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll] - , abs(d__1)))); - sminl = min(sminl,mu); -/* L110: */ - } - } - } - oldll = ll; - oldm = m; - -/* Compute shift. First, test if shifting would ruin relative - accuracy, and if so set the shift to zero. - - Computing MAX */ - d__1 = eps, d__2 = tol * .01; - if (tol >= 0. && *n * tol * (sminl / smax) <= max(d__1,d__2)) { - -/* Use a zero shift to avoid loss of relative accuracy */ - - shift = 0.; - } else { - -/* Compute the shift from 2-by-2 block at end of matrix */ - - if (idir == 1) { - sll = (d__1 = d__[ll], abs(d__1)); - dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__); - } else { - sll = (d__1 = d__[m], abs(d__1)); - dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__); - } - -/* Test if shift negligible, and if so set to zero */ - - if (sll > 0.) { -/* Computing 2nd power */ - d__1 = shift / sll; - if (d__1 * d__1 < eps) { - shift = 0.; - } - } - } - -/* Increment iteration count */ - - iter = iter + m - ll; - -/* If SHIFT = 0, do simplified QR iteration */ - - if (shift == 0.) { - if (idir == 1) { - -/* Chase bulge from top to bottom - Save cosines and sines for later singular vector updates */ - - cs = 1.; - oldcs = 1.; - i__1 = m - 1; - for (i__ = ll; i__ <= i__1; ++i__) { - d__1 = d__[i__] * cs; - dlartg_(&d__1, &e[i__], &cs, &sn, &r__); - if (i__ > ll) { - e[i__ - 1] = oldsn * r__; - } - d__1 = oldcs * r__; - d__2 = d__[i__ + 1] * sn; - dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); - work[i__ - ll + 1] = cs; - work[i__ - ll + 1 + nm1] = sn; - work[i__ - ll + 1 + nm12] = oldcs; - work[i__ - ll + 1 + nm13] = oldsn; -/* L120: */ - } - h__ = d__[m] * cs; - d__[m] = h__ * oldcs; - e[m - 1] = h__ * oldsn; - -/* Update singular vectors */ - - if (*ncvt > 0) { - i__1 = m - ll + 1; - dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], & - vt_ref(ll, 1), ldvt); - } - if (*nru > 0) { - i__1 = m - ll + 1; - dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13 - + 1], &u_ref(1, ll), ldu); - } - if (*ncc > 0) { - i__1 = m - ll + 1; - dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13 - + 1], &c___ref(ll, 1), ldc); - } - -/* Test convergence */ - - if ((d__1 = e[m - 1], abs(d__1)) <= thresh) { - e[m - 1] = 0.; - } - - } else { - -/* Chase bulge from bottom to top - Save cosines and sines for later singular vector updates */ - - cs = 1.; - oldcs = 1.; - i__1 = ll + 1; - for (i__ = m; i__ >= i__1; --i__) { - d__1 = d__[i__] * cs; - dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__); - if (i__ < m) { - e[i__] = oldsn * r__; - } - d__1 = oldcs * r__; - d__2 = d__[i__ - 1] * sn; - dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); - work[i__ - ll] = cs; - work[i__ - ll + nm1] = -sn; - work[i__ - ll + nm12] = oldcs; - work[i__ - ll + nm13] = -oldsn; -/* L130: */ - } - h__ = d__[ll] * cs; - d__[ll] = h__ * oldcs; - e[ll] = h__ * oldsn; - -/* Update singular vectors */ - - if (*ncvt > 0) { - i__1 = m - ll + 1; - dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[ - nm13 + 1], &vt_ref(ll, 1), ldvt); - } - if (*nru > 0) { - i__1 = m - ll + 1; - dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u_ref( - 1, ll), ldu); - } - if (*ncc > 0) { - i__1 = m - ll + 1; - dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], & - c___ref(ll, 1), ldc); - } - -/* Test convergence */ - - if ((d__1 = e[ll], abs(d__1)) <= thresh) { - e[ll] = 0.; - } - } - } else { - -/* Use nonzero shift */ - - if (idir == 1) { - -/* Chase bulge from top to bottom - Save cosines and sines for later singular vector updates */ - - f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[ - ll]) + shift / d__[ll]); - g = e[ll]; - i__1 = m - 1; - for (i__ = ll; i__ <= i__1; ++i__) { - dlartg_(&f, &g, &cosr, &sinr, &r__); - if (i__ > ll) { - e[i__ - 1] = r__; - } - f = cosr * d__[i__] + sinr * e[i__]; - e[i__] = cosr * e[i__] - sinr * d__[i__]; - g = sinr * d__[i__ + 1]; - d__[i__ + 1] = cosr * d__[i__ + 1]; - dlartg_(&f, &g, &cosl, &sinl, &r__); - d__[i__] = r__; - f = cosl * e[i__] + sinl * d__[i__ + 1]; - d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__]; - if (i__ < m - 1) { - g = sinl * e[i__ + 1]; - e[i__ + 1] = cosl * e[i__ + 1]; - } - work[i__ - ll + 1] = cosr; - work[i__ - ll + 1 + nm1] = sinr; - work[i__ - ll + 1 + nm12] = cosl; - work[i__ - ll + 1 + nm13] = sinl; -/* L140: */ - } - e[m - 1] = f; - -/* Update singular vectors */ - - if (*ncvt > 0) { - i__1 = m - ll + 1; - dlasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], & - vt_ref(ll, 1), ldvt); - } - if (*nru > 0) { - i__1 = m - ll + 1; - dlasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13 - + 1], &u_ref(1, ll), ldu); - } - if (*ncc > 0) { - i__1 = m - ll + 1; - dlasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13 - + 1], &c___ref(ll, 1), ldc); - } - -/* Test convergence */ - - if ((d__1 = e[m - 1], abs(d__1)) <= thresh) { - e[m - 1] = 0.; - } - - } else { - -/* Chase bulge from bottom to top - Save cosines and sines for later singular vector updates */ - - f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m] - ) + shift / d__[m]); - g = e[m - 1]; - i__1 = ll + 1; - for (i__ = m; i__ >= i__1; --i__) { - dlartg_(&f, &g, &cosr, &sinr, &r__); - if (i__ < m) { - e[i__] = r__; - } - f = cosr * d__[i__] + sinr * e[i__ - 1]; - e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__]; - g = sinr * d__[i__ - 1]; - d__[i__ - 1] = cosr * d__[i__ - 1]; - dlartg_(&f, &g, &cosl, &sinl, &r__); - d__[i__] = r__; - f = cosl * e[i__ - 1] + sinl * d__[i__ - 1]; - d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1]; - if (i__ > ll + 1) { - g = sinl * e[i__ - 2]; - e[i__ - 2] = cosl * e[i__ - 2]; - } - work[i__ - ll] = cosr; - work[i__ - ll + nm1] = -sinr; - work[i__ - ll + nm12] = cosl; - work[i__ - ll + nm13] = -sinl; -/* L150: */ - } - e[ll] = f; - -/* Test convergence */ - - if ((d__1 = e[ll], abs(d__1)) <= thresh) { - e[ll] = 0.; - } - -/* Update singular vectors if desired */ - - if (*ncvt > 0) { - i__1 = m - ll + 1; - dlasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[ - nm13 + 1], &vt_ref(ll, 1), ldvt); - } - if (*nru > 0) { - i__1 = m - ll + 1; - dlasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u_ref( - 1, ll), ldu); - } - if (*ncc > 0) { - i__1 = m - ll + 1; - dlasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], & - c___ref(ll, 1), ldc); - } - } - } - -/* QR iteration finished, go back and check convergence */ - - goto L60; - -/* All singular values converged, so make them positive */ - -L160: - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (d__[i__] < 0.) { - d__[i__] = -d__[i__]; - -/* Change sign of singular vectors, if desired */ - - if (*ncvt > 0) { - dscal_(ncvt, &c_b72, &vt_ref(i__, 1), ldvt); - } - } -/* L170: */ - } - -/* Sort the singular values into decreasing order (insertion sort on - singular values, but only one transposition per singular vector) */ - - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Scan for smallest D(I) */ - - isub = 1; - smin = d__[1]; - i__2 = *n + 1 - i__; - for (j = 2; j <= i__2; ++j) { - if (d__[j] <= smin) { - isub = j; - smin = d__[j]; - } -/* L180: */ - } - if (isub != *n + 1 - i__) { - -/* Swap singular values and vectors */ - - d__[isub] = d__[*n + 1 - i__]; - d__[*n + 1 - i__] = smin; - if (*ncvt > 0) { - dswap_(ncvt, &vt_ref(isub, 1), ldvt, &vt_ref(*n + 1 - i__, 1), - ldvt); - } - if (*nru > 0) { - dswap_(nru, &u_ref(1, isub), &c__1, &u_ref(1, *n + 1 - i__), & - c__1); - } - if (*ncc > 0) { - dswap_(ncc, &c___ref(isub, 1), ldc, &c___ref(*n + 1 - i__, 1), - ldc); - } - } -/* L190: */ - } - goto L220; - -/* Maximum number of iterations exceeded, failure to converge */ - -L200: - *info = 0; - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - if (e[i__] != 0.) { - ++(*info); - } -/* L210: */ - } -L220: - return 0; - -/* End of DBDSQR */ - -} /* dbdsqr_ */ - -#undef vt_ref -#undef u_ref -#undef c___ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgbcon.c b/ext/f2c_lapack/dgbcon.c deleted file mode 100644 index 72083f759..000000000 --- a/ext/f2c_lapack/dgbcon.c +++ /dev/null @@ -1,283 +0,0 @@ -/* dgbcon.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dgbcon_(char *norm, integer *n, integer *kl, integer *ku, - doublereal *ab, integer *ldab, integer *ipiv, doublereal *anorm, - doublereal *rcond, doublereal *work, integer *iwork, integer *info, - ftnlen norm_len) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3; - doublereal d__1; - - /* Local variables */ - static integer j; - static doublereal t; - static integer kd, lm, jp, ix, kase; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); - static integer kase1; - static doublereal scale; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *, - integer *); - static logical lnoti; - extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - extern doublereal dlamch_(char *, ftnlen); - extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - extern integer idamax_(integer *, doublereal *, integer *); - extern /* Subroutine */ int dlatbs_(char *, char *, char *, char *, - integer *, integer *, doublereal *, integer *, doublereal *, - doublereal *, doublereal *, integer *, ftnlen, ftnlen, ftnlen, - ftnlen), xerbla_(char *, integer *, ftnlen); - static doublereal ainvnm; - static logical onenrm; - static char normin[1]; - static doublereal smlnum; - - -/* -- LAPACK routine (version 3.0) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ -/* Courant Institute, Argonne National Lab, and Rice University */ -/* September 30, 1994 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGBCON estimates the reciprocal of the condition number of a real */ -/* general band matrix A, in either the 1-norm or the infinity-norm, */ -/* using the LU factorization computed by DGBTRF. */ - -/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ -/* condition number is computed as */ -/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies whether the 1-norm condition number or the */ -/* infinity-norm condition number is required: */ -/* = '1' or 'O': 1-norm; */ -/* = 'I': Infinity-norm. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* Details of the LU factorization of the band matrix A, as */ -/* computed by DGBTRF. U is stored as an upper triangular band */ -/* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ -/* the multipliers used during the factorization are stored in */ -/* rows KL+KU+2 to 2*KL+KU+1. */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* The pivot indices; for 1 <= i <= N, row i of the matrix was */ -/* interchanged with row IPIV(i). */ - -/* ANORM (input) DOUBLE PRECISION */ -/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */ -/* If NORM = 'I', the infinity-norm of the original matrix A. */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The reciprocal of the condition number of the matrix A, */ -/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --ipiv; - --work; - --iwork; - - /* Function Body */ - *info = 0; - onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O", (ftnlen)1, ( - ftnlen)1); - if (! onenrm && ! lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kl < 0) { - *info = -3; - } else if (*ku < 0) { - *info = -4; - } else if (*ldab < (*kl << 1) + *ku + 1) { - *info = -6; - } else if (*anorm < 0.) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBCON", &i__1, (ftnlen)6); - return 0; - } - -/* Quick return if possible */ - - *rcond = 0.; - if (*n == 0) { - *rcond = 1.; - return 0; - } else if (*anorm == 0.) { - return 0; - } - - smlnum = dlamch_("Safe minimum", (ftnlen)12); - -/* Estimate the norm of inv(A). */ - - ainvnm = 0.; - *(unsigned char *)normin = 'N'; - if (onenrm) { - kase1 = 1; - } else { - kase1 = 2; - } - kd = *kl + *ku + 1; - lnoti = *kl > 0; - kase = 0; -L10: - dlacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase); - if (kase != 0) { - if (kase == kase1) { - -/* Multiply by inv(L). */ - - if (lnoti) { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__2 = *kl, i__3 = *n - j; - lm = min(i__2,i__3); - jp = ipiv[j]; - t = work[jp]; - if (jp != j) { - work[jp] = work[j]; - work[j] = t; - } - d__1 = -t; - daxpy_(&lm, &d__1, &ab[kd + 1 + j * ab_dim1], &c__1, & - work[j + 1], &c__1); -/* L20: */ - } - } - -/* Multiply by inv(U). */ - - i__1 = *kl + *ku; - dlatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, & - ab[ab_offset], ldab, &work[1], &scale, &work[(*n << 1) + - 1], info, (ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1); - } else { - -/* Multiply by inv(U'). */ - - i__1 = *kl + *ku; - dlatbs_("Upper", "Transpose", "Non-unit", normin, n, &i__1, &ab[ - ab_offset], ldab, &work[1], &scale, &work[(*n << 1) + 1], - info, (ftnlen)5, (ftnlen)9, (ftnlen)8, (ftnlen)1); - -/* Multiply by inv(L'). */ - - if (lnoti) { - for (j = *n - 1; j >= 1; --j) { -/* Computing MIN */ - i__1 = *kl, i__2 = *n - j; - lm = min(i__1,i__2); - work[j] -= ddot_(&lm, &ab[kd + 1 + j * ab_dim1], &c__1, & - work[j + 1], &c__1); - jp = ipiv[j]; - if (jp != j) { - t = work[jp]; - work[jp] = work[j]; - work[j] = t; - } -/* L30: */ - } - } - } - -/* Divide X by 1/SCALE if doing so will not cause overflow. */ - - *(unsigned char *)normin = 'Y'; - if (scale != 1.) { - ix = idamax_(n, &work[1], &c__1); - if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.) - { - goto L40; - } - drscl_(n, &scale, &work[1], &c__1); - } - goto L10; - } - -/* Compute the estimate of the reciprocal condition number. */ - - if (ainvnm != 0.) { - *rcond = 1. / ainvnm / *anorm; - } - -L40: - return 0; - -/* End of DGBCON */ - -} /* dgbcon_ */ - diff --git a/ext/f2c_lapack/dgbequ.c b/ext/f2c_lapack/dgbequ.c deleted file mode 100644 index 1c26aadfd..000000000 --- a/ext/f2c_lapack/dgbequ.c +++ /dev/null @@ -1,321 +0,0 @@ -/* dgbequ.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "f2c.h" - -/* Subroutine */ int dgbequ_(integer *m, integer *n, integer *kl, integer *ku, - doublereal *ab, integer *ldab, doublereal *r__, doublereal *c__, - doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer * - info) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; - doublereal d__1, d__2, d__3; - - /* Local variables */ - static integer i__, j, kd; - static doublereal rcmin, rcmax; - extern doublereal dlamch_(char *, ftnlen); - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - static doublereal bignum, smlnum; - - -/* -- LAPACK routine (version 3.0) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ -/* Courant Institute, Argonne National Lab, and Rice University */ -/* March 31, 1993 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGBEQU computes row and column scalings intended to equilibrate an */ -/* M-by-N band matrix A and reduce its condition number. R returns the */ -/* row scale factors and C the column scale factors, chosen to try to */ -/* make the largest element in each row and column of the matrix B with */ -/* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */ - -/* R(i) and C(j) are restricted to be between SMLNUM = smallest safe */ -/* number and BIGNUM = largest safe number. Use of these scaling */ -/* factors is not guaranteed to reduce the condition number of A but */ -/* works well in practice. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. N >= 0. */ - -/* KL (input) INTEGER */ -/* The number of subdiagonals within the band of A. KL >= 0. */ - -/* KU (input) INTEGER */ -/* The number of superdiagonals within the band of A. KU >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* The band matrix A, stored in rows 1 to KL+KU+1. The j-th */ -/* column of A is stored in the j-th column of the array AB as */ -/* follows: */ -/* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KL+KU+1. */ - -/* R (output) DOUBLE PRECISION array, dimension (M) */ -/* If INFO = 0, or INFO > M, R contains the row scale factors */ -/* for A. */ - -/* C (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, C contains the column scale factors for A. */ - -/* ROWCND (output) DOUBLE PRECISION */ -/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */ -/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */ -/* AMAX is neither too large nor too small, it is not worth */ -/* scaling by R. */ - -/* COLCND (output) DOUBLE PRECISION */ -/* If INFO = 0, COLCND contains the ratio of the smallest */ -/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */ -/* worth scaling by C. */ - -/* AMAX (output) DOUBLE PRECISION */ -/* Absolute value of largest matrix element. If AMAX is very */ -/* close to overflow or very close to underflow, the matrix */ -/* should be scaled. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, and i is */ -/* <= M: the i-th row of A is exactly zero */ -/* > M: the (i-M)-th column of A is exactly zero */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --r__; - --c__; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kl < 0) { - *info = -3; - } else if (*ku < 0) { - *info = -4; - } else if (*ldab < *kl + *ku + 1) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBEQU", &i__1, (ftnlen)6); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - *rowcnd = 1.; - *colcnd = 1.; - *amax = 0.; - return 0; - } - -/* Get machine constants. */ - - smlnum = dlamch_("S", (ftnlen)1); - bignum = 1. / smlnum; - -/* Compute row scale factors. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - r__[i__] = 0.; -/* L10: */ - } - -/* Find the maximum element in each row. */ - - kd = *ku + 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__2 = j - *ku; -/* Computing MIN */ - i__4 = j + *kl; - i__3 = min(i__4,*m); - for (i__ = max(i__2,1); i__ <= i__3; ++i__) { -/* Computing MAX */ - d__2 = r__[i__], d__3 = (d__1 = ab[kd + i__ - j + j * ab_dim1], - abs(d__1)); - r__[i__] = max(d__2,d__3); -/* L20: */ - } -/* L30: */ - } - -/* Find the maximum and minimum scale factors. */ - - rcmin = bignum; - rcmax = 0.; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = rcmax, d__2 = r__[i__]; - rcmax = max(d__1,d__2); -/* Computing MIN */ - d__1 = rcmin, d__2 = r__[i__]; - rcmin = min(d__1,d__2); -/* L40: */ - } - *amax = rcmax; - - if (rcmin == 0.) { - -/* Find the first zero scale factor and return an error code. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (r__[i__] == 0.) { - *info = i__; - return 0; - } -/* L50: */ - } - } else { - -/* Invert the scale factors. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MIN */ -/* Computing MAX */ - d__2 = r__[i__]; - d__1 = max(d__2,smlnum); - r__[i__] = 1. / min(d__1,bignum); -/* L60: */ - } - -/* Compute ROWCND = min(R(I)) / max(R(I)) */ - - *rowcnd = max(rcmin,smlnum) / min(rcmax,bignum); - } - -/* Compute column scale factors */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - c__[j] = 0.; -/* L70: */ - } - -/* Find the maximum element in each column, */ -/* assuming the row scaling computed above. */ - - kd = *ku + 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__3 = j - *ku; -/* Computing MIN */ - i__4 = j + *kl; - i__2 = min(i__4,*m); - for (i__ = max(i__3,1); i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = c__[j], d__3 = (d__1 = ab[kd + i__ - j + j * ab_dim1], abs( - d__1)) * r__[i__]; - c__[j] = max(d__2,d__3); -/* L80: */ - } -/* L90: */ - } - -/* Find the maximum and minimum scale factors. */ - - rcmin = bignum; - rcmax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = rcmin, d__2 = c__[j]; - rcmin = min(d__1,d__2); -/* Computing MAX */ - d__1 = rcmax, d__2 = c__[j]; - rcmax = max(d__1,d__2); -/* L100: */ - } - - if (rcmin == 0.) { - -/* Find the first zero scale factor and return an error code. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (c__[j] == 0.) { - *info = *m + j; - return 0; - } -/* L110: */ - } - } else { - -/* Invert the scale factors. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ -/* Computing MAX */ - d__2 = c__[j]; - d__1 = max(d__2,smlnum); - c__[j] = 1. / min(d__1,bignum); -/* L120: */ - } - -/* Compute COLCND = min(C(J)) / max(C(J)) */ - - *colcnd = max(rcmin,smlnum) / min(rcmax,bignum); - } - - return 0; - -/* End of DGBEQU */ - -} /* dgbequ_ */ - diff --git a/ext/f2c_lapack/dgbrfs.c b/ext/f2c_lapack/dgbrfs.c deleted file mode 100644 index 312d39ee8..000000000 --- a/ext/f2c_lapack/dgbrfs.c +++ /dev/null @@ -1,433 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgbrfs_(char *trans, integer *n, integer *kl, integer * - ku, integer *nrhs, doublereal *ab, integer *ldab, doublereal *afb, - integer *ldafb, integer *ipiv, doublereal *b, integer *ldb, - doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, - doublereal *work, integer *iwork, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - September 30, 1994 - - - Purpose - ======= - - DGBRFS improves the computed solution to a system of linear - equations when the coefficient matrix is banded, and provides - error bounds and backward error estimates for the solution. - - Arguments - ========= - - TRANS (input) CHARACTER*1 - Specifies the form of the system of equations: - = 'N': A * X = B (No transpose) - = 'T': A**T * X = B (Transpose) - = 'C': A**H * X = B (Conjugate transpose = Transpose) - - N (input) INTEGER - The order of the matrix A. N >= 0. - - KL (input) INTEGER - The number of subdiagonals within the band of A. KL >= 0. - - KU (input) INTEGER - The number of superdiagonals within the band of A. KU >= 0. - - NRHS (input) INTEGER - The number of right hand sides, i.e., the number of columns - of the matrices B and X. NRHS >= 0. - - AB (input) DOUBLE PRECISION array, dimension (LDAB,N) - The original band matrix A, stored in rows 1 to KL+KU+1. - The j-th column of A is stored in the j-th column of the - array AB as follows: - AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl). - - LDAB (input) INTEGER - The leading dimension of the array AB. LDAB >= KL+KU+1. - - AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N) - Details of the LU factorization of the band matrix A, as - computed by DGBTRF. U is stored as an upper triangular band - matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and - the multipliers used during the factorization are stored in - rows KL+KU+2 to 2*KL+KU+1. - - LDAFB (input) INTEGER - The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. - - IPIV (input) INTEGER array, dimension (N) - The pivot indices from DGBTRF; for 1<=i<=N, row i of the - matrix was interchanged with row IPIV(i). - - B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) - The right hand side matrix B. - - LDB (input) INTEGER - The leading dimension of the array B. LDB >= max(1,N). - - X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) - On entry, the solution matrix X, as computed by DGBTRS. - On exit, the improved solution matrix X. - - LDX (input) INTEGER - The leading dimension of the array X. LDX >= max(1,N). - - FERR (output) DOUBLE PRECISION array, dimension (NRHS) - The estimated forward error bound for each solution vector - X(j) (the j-th column of the solution matrix X). - If XTRUE is the true solution corresponding to X(j), FERR(j) - is an estimated upper bound for the magnitude of the largest - element in (X(j) - XTRUE) divided by the magnitude of the - largest element in X(j). The estimate is as reliable as - the estimate for RCOND, and is almost always a slight - overestimate of the true error. - - BERR (output) DOUBLE PRECISION array, dimension (NRHS) - The componentwise relative backward error of each solution - vector X(j) (i.e., the smallest relative change in - any element of A or B that makes X(j) an exact solution). - - WORK (workspace) DOUBLE PRECISION array, dimension (3*N) - - IWORK (workspace) INTEGER array, dimension (N) - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - - Internal Parameters - =================== - - ITMAX is the maximum number of steps of iterative refinement. - - ===================================================================== - - - Test the input parameters. - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static doublereal c_b15 = -1.; - static doublereal c_b17 = 1.; - - /* System generated locals */ - integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, - x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; - doublereal d__1, d__2, d__3; - /* Local variables */ - static integer kase; - static doublereal safe1, safe2; - static integer i__, j, k; - static doublereal s; - extern /* Subroutine */ int dgbmv_(char *, integer *, integer *, integer * - , integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *), daxpy_(integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *); - static integer count, kk; - extern doublereal dlamch_(char *); - extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - static doublereal xk; - static integer nz; - static doublereal safmin; - extern /* Subroutine */ int xerbla_(char *, integer *), dgbtrs_( - char *, integer *, integer *, integer *, integer *, doublereal *, - integer *, integer *, doublereal *, integer *, integer *); - static logical notran; - static char transt[1]; - static doublereal lstres, eps; -#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] -#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1] -#define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1] - - - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1 * 1; - ab -= ab_offset; - afb_dim1 = *ldafb; - afb_offset = 1 + afb_dim1 * 1; - afb -= afb_offset; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1 * 1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - notran = lsame_(trans, "N"); - if (! notran && ! lsame_(trans, "T") && ! lsame_( - trans, "C")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kl < 0) { - *info = -3; - } else if (*ku < 0) { - *info = -4; - } else if (*nrhs < 0) { - *info = -5; - } else if (*ldab < *kl + *ku + 1) { - *info = -7; - } else if (*ldafb < (*kl << 1) + *ku + 1) { - *info = -9; - } else if (*ldb < max(1,*n)) { - *info = -12; - } else if (*ldx < max(1,*n)) { - *info = -14; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBRFS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] = 0.; - berr[j] = 0.; -/* L10: */ - } - return 0; - } - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - -/* NZ = maximum number of nonzero elements in each row of A, plus 1 - - Computing MIN */ - i__1 = *kl + *ku + 2, i__2 = *n + 1; - nz = min(i__1,i__2); - eps = dlamch_("Epsilon"); - safmin = dlamch_("Safe minimum"); - safe1 = nz * safmin; - safe2 = safe1 / eps; - -/* Do for each right hand side */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - - count = 1; - lstres = 3.; -L20: - -/* Loop until stopping criterion is satisfied. - - Compute residual R = B - op(A) * X, - where op(A) = A, A**T, or A**H, depending on TRANS. */ - - dcopy_(n, &b_ref(1, j), &c__1, &work[*n + 1], &c__1); - dgbmv_(trans, n, n, kl, ku, &c_b15, &ab[ab_offset], ldab, &x_ref(1, j) - , &c__1, &c_b17, &work[*n + 1], &c__1); - -/* Compute componentwise relative backward error from formula - - max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) - - where abs(Z) is the componentwise absolute value of the matrix - or vector Z. If the i-th component of the denominator is less - than SAFE2, then SAFE1 is added to the i-th components of the - numerator and denominator before dividing. */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] = (d__1 = b_ref(i__, j), abs(d__1)); -/* L30: */ - } - -/* Compute abs(op(A))*abs(X) + abs(B). */ - - if (notran) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - kk = *ku + 1 - k; - xk = (d__1 = x_ref(k, j), abs(d__1)); -/* Computing MAX */ - i__3 = 1, i__4 = k - *ku; -/* Computing MIN */ - i__6 = *n, i__7 = k + *kl; - i__5 = min(i__6,i__7); - for (i__ = max(i__3,i__4); i__ <= i__5; ++i__) { - work[i__] += (d__1 = ab_ref(kk + i__, k), abs(d__1)) * xk; -/* L40: */ - } -/* L50: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - kk = *ku + 1 - k; -/* Computing MAX */ - i__5 = 1, i__3 = k - *ku; -/* Computing MIN */ - i__6 = *n, i__7 = k + *kl; - i__4 = min(i__6,i__7); - for (i__ = max(i__5,i__3); i__ <= i__4; ++i__) { - s += (d__1 = ab_ref(kk + i__, k), abs(d__1)) * (d__2 = - x_ref(i__, j), abs(d__2)); -/* L60: */ - } - work[k] += s; -/* L70: */ - } - } - s = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { -/* Computing MAX */ - d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ - i__]; - s = max(d__2,d__3); - } else { -/* Computing MAX */ - d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) - / (work[i__] + safe1); - s = max(d__2,d__3); - } -/* L80: */ - } - berr[j] = s; - -/* Test stopping criterion. Continue iterating if - 1) The residual BERR(J) is larger than machine epsilon, and - 2) BERR(J) decreased by at least a factor of 2 during the - last iteration, and - 3) At most ITMAX iterations tried. */ - - if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { - -/* Update solution and try again. */ - - dgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1] - , &work[*n + 1], n, info); - daxpy_(n, &c_b17, &work[*n + 1], &c__1, &x_ref(1, j), &c__1); - lstres = berr[j]; - ++count; - goto L20; - } - -/* Bound error from formula - - norm(X - XTRUE) / norm(X) .le. FERR = - norm( abs(inv(op(A)))* - ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) - - where - norm(Z) is the magnitude of the largest component of Z - inv(op(A)) is the inverse of op(A) - abs(Z) is the componentwise absolute value of the matrix or - vector Z - NZ is the maximum number of nonzeros in any row of A, plus 1 - EPS is machine epsilon - - The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) - is incremented by SAFE1 if the i-th component of - abs(op(A))*abs(X) + abs(B) is less than SAFE2. - - Use DLACON to estimate the infinity-norm of the matrix - inv(op(A)) * diag(W), - where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__]; - } else { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__] + safe1; - } -/* L90: */ - } - - kase = 0; -L100: - dlacon_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & - kase); - if (kase != 0) { - if (kase == 1) { - -/* Multiply by diag(W)*inv(op(A)**T). */ - - dgbtrs_(transt, n, kl, ku, &c__1, &afb[afb_offset], ldafb, & - ipiv[1], &work[*n + 1], n, info); - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] *= work[i__]; -/* L110: */ - } - } else { - -/* Multiply by inv(op(A))*diag(W). */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] *= work[i__]; -/* L120: */ - } - dgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, & - ipiv[1], &work[*n + 1], n, info); - } - goto L100; - } - -/* Normalize error. */ - - lstres = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = lstres, d__3 = (d__1 = x_ref(i__, j), abs(d__1)); - lstres = max(d__2,d__3); -/* L130: */ - } - if (lstres != 0.) { - ferr[j] /= lstres; - } - -/* L140: */ - } - - return 0; - -/* End of DGBRFS */ - -} /* dgbrfs_ */ - -#undef ab_ref -#undef x_ref -#undef b_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgbsv.c b/ext/f2c_lapack/dgbsv.c deleted file mode 100644 index f82bb1a99..000000000 --- a/ext/f2c_lapack/dgbsv.c +++ /dev/null @@ -1,161 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgbsv_(integer *n, integer *kl, integer *ku, integer * - nrhs, doublereal *ab, integer *ldab, integer *ipiv, doublereal *b, - integer *ldb, integer *info) -{ -/* -- LAPACK driver routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - March 31, 1993 - - - Purpose - ======= - - DGBSV computes the solution to a real system of linear equations - A * X = B, where A is a band matrix of order N with KL subdiagonals - and KU superdiagonals, and X and B are N-by-NRHS matrices. - - The LU decomposition with partial pivoting and row interchanges is - used to factor A as A = L * U, where L is a product of permutation - and unit lower triangular matrices with KL subdiagonals, and U is - upper triangular with KL+KU superdiagonals. The factored form of A - is then used to solve the system of equations A * X = B. - - Arguments - ========= - - N (input) INTEGER - The number of linear equations, i.e., the order of the - matrix A. N >= 0. - - KL (input) INTEGER - The number of subdiagonals within the band of A. KL >= 0. - - KU (input) INTEGER - The number of superdiagonals within the band of A. KU >= 0. - - NRHS (input) INTEGER - The number of right hand sides, i.e., the number of columns - of the matrix B. NRHS >= 0. - - AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) - On entry, the matrix A in band storage, in rows KL+1 to - 2*KL+KU+1; rows 1 to KL of the array need not be set. - The j-th column of A is stored in the j-th column of the - array AB as follows: - AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL) - On exit, details of the factorization: U is stored as an - upper triangular band matrix with KL+KU superdiagonals in - rows 1 to KL+KU+1, and the multipliers used during the - factorization are stored in rows KL+KU+2 to 2*KL+KU+1. - See below for further details. - - LDAB (input) INTEGER - The leading dimension of the array AB. LDAB >= 2*KL+KU+1. - - IPIV (output) INTEGER array, dimension (N) - The pivot indices that define the permutation matrix P; - row i of the matrix was interchanged with row IPIV(i). - - B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) - On entry, the N-by-NRHS right hand side matrix B. - On exit, if INFO = 0, the N-by-NRHS solution matrix X. - - LDB (input) INTEGER - The leading dimension of the array B. LDB >= max(1,N). - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - > 0: if INFO = i, U(i,i) is exactly zero. The factorization - has been completed, but the factor U is exactly - singular, and the solution has not been computed. - - Further Details - =============== - - The band storage scheme is illustrated by the following example, when - M = N = 6, KL = 2, KU = 1: - - On entry: On exit: - - * * * + + + * * * u14 u25 u36 - * * + + + + * * u13 u24 u35 u46 - * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 - a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 - a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * - a31 a42 a53 a64 * * m31 m42 m53 m64 * * - - Array elements marked * are not used by the routine; elements marked - + need not be set on entry, but are required by the routine to store - elements of U because of fill-in resulting from the row interchanges. - - ===================================================================== - - - Test the input parameters. - - Parameter adjustments */ - /* System generated locals */ - integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; - /* Local variables */ - extern /* Subroutine */ int dgbtrf_(integer *, integer *, integer *, - integer *, doublereal *, integer *, integer *, integer *), - xerbla_(char *, integer *), dgbtrs_(char *, integer *, - integer *, integer *, integer *, doublereal *, integer *, integer - *, doublereal *, integer *, integer *); - - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1 * 1; - ab -= ab_offset; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - - /* Function Body */ - *info = 0; - if (*n < 0) { - *info = -1; - } else if (*kl < 0) { - *info = -2; - } else if (*ku < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*ldab < (*kl << 1) + *ku + 1) { - *info = -6; - } else if (*ldb < max(*n,1)) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBSV ", &i__1); - return 0; - } - -/* Compute the LU factorization of the band matrix A. */ - - dgbtrf_(n, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info); - if (*info == 0) { - -/* Solve the system A*X = B, overwriting B with X. */ - - dgbtrs_("No transpose", n, kl, ku, nrhs, &ab[ab_offset], ldab, &ipiv[ - 1], &b[b_offset], ldb, info); - } - return 0; - -/* End of DGBSV */ - -} /* dgbsv_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgbtf2.c b/ext/f2c_lapack/dgbtf2.c deleted file mode 100644 index 0e925dbd5..000000000 --- a/ext/f2c_lapack/dgbtf2.c +++ /dev/null @@ -1,247 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgbtf2_(integer *m, integer *n, integer *kl, integer *ku, - doublereal *ab, integer *ldab, integer *ipiv, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - February 29, 1992 - - - Purpose - ======= - - DGBTF2 computes an LU factorization of a real m-by-n band matrix A - using partial pivoting with row interchanges. - - This is the unblocked version of the algorithm, calling Level 2 BLAS. - - Arguments - ========= - - M (input) INTEGER - The number of rows of the matrix A. M >= 0. - - N (input) INTEGER - The number of columns of the matrix A. N >= 0. - - KL (input) INTEGER - The number of subdiagonals within the band of A. KL >= 0. - - KU (input) INTEGER - The number of superdiagonals within the band of A. KU >= 0. - - AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) - On entry, the matrix A in band storage, in rows KL+1 to - 2*KL+KU+1; rows 1 to KL of the array need not be set. - The j-th column of A is stored in the j-th column of the - array AB as follows: - AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) - - On exit, details of the factorization: U is stored as an - upper triangular band matrix with KL+KU superdiagonals in - rows 1 to KL+KU+1, and the multipliers used during the - factorization are stored in rows KL+KU+2 to 2*KL+KU+1. - See below for further details. - - LDAB (input) INTEGER - The leading dimension of the array AB. LDAB >= 2*KL+KU+1. - - IPIV (output) INTEGER array, dimension (min(M,N)) - The pivot indices; for 1 <= i <= min(M,N), row i of the - matrix was interchanged with row IPIV(i). - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - > 0: if INFO = +i, U(i,i) is exactly zero. The factorization - has been completed, but the factor U is exactly - singular, and division by zero will occur if it is used - to solve a system of equations. - - Further Details - =============== - - The band storage scheme is illustrated by the following example, when - M = N = 6, KL = 2, KU = 1: - - On entry: On exit: - - * * * + + + * * * u14 u25 u36 - * * + + + + * * u13 u24 u35 u46 - * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 - a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 - a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * - a31 a42 a53 a64 * * m31 m42 m53 m64 * * - - Array elements marked * are not used by the routine; elements marked - + need not be set on entry, but are required by the routine to store - elements of U, because of fill-in resulting from the row - interchanges. - - ===================================================================== - - - KV is the number of superdiagonals in the factor U, allowing for - fill-in. - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static doublereal c_b9 = -1.; - - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; - doublereal d__1; - /* Local variables */ - extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *); - static integer i__, j; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dswap_(integer *, doublereal *, integer *, doublereal - *, integer *); - static integer km, jp, ju, kv; - extern integer idamax_(integer *, doublereal *, integer *); - extern /* Subroutine */ int xerbla_(char *, integer *); -#define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1] - - - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1 * 1; - ab -= ab_offset; - --ipiv; - - /* Function Body */ - kv = *ku + *kl; - -/* Test the input parameters. */ - - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kl < 0) { - *info = -3; - } else if (*ku < 0) { - *info = -4; - } else if (*ldab < *kl + kv + 1) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBTF2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* Gaussian elimination with partial pivoting - - Set fill-in elements in columns KU+2 to KV to zero. */ - - i__1 = min(kv,*n); - for (j = *ku + 2; j <= i__1; ++j) { - i__2 = *kl; - for (i__ = kv - j + 2; i__ <= i__2; ++i__) { - ab_ref(i__, j) = 0.; -/* L10: */ - } -/* L20: */ - } - -/* JU is the index of the last column affected by the current stage - of the factorization. */ - - ju = 1; - - i__1 = min(*m,*n); - for (j = 1; j <= i__1; ++j) { - -/* Set fill-in elements in column J+KV to zero. */ - - if (j + kv <= *n) { - i__2 = *kl; - for (i__ = 1; i__ <= i__2; ++i__) { - ab_ref(i__, j + kv) = 0.; -/* L30: */ - } - } - -/* Find pivot and test for singularity. KM is the number of - subdiagonal elements in the current column. - - Computing MIN */ - i__2 = *kl, i__3 = *m - j; - km = min(i__2,i__3); - i__2 = km + 1; - jp = idamax_(&i__2, &ab_ref(kv + 1, j), &c__1); - ipiv[j] = jp + j - 1; - if (ab_ref(kv + jp, j) != 0.) { -/* Computing MAX - Computing MIN */ - i__4 = j + *ku + jp - 1; - i__2 = ju, i__3 = min(i__4,*n); - ju = max(i__2,i__3); - -/* Apply interchange to columns J to JU. */ - - if (jp != 1) { - i__2 = ju - j + 1; - i__3 = *ldab - 1; - i__4 = *ldab - 1; - dswap_(&i__2, &ab_ref(kv + jp, j), &i__3, &ab_ref(kv + 1, j), - &i__4); - } - - if (km > 0) { - -/* Compute multipliers. */ - - d__1 = 1. / ab_ref(kv + 1, j); - dscal_(&km, &d__1, &ab_ref(kv + 2, j), &c__1); - -/* Update trailing submatrix within the band. */ - - if (ju > j) { - i__2 = ju - j; - i__3 = *ldab - 1; - i__4 = *ldab - 1; - dger_(&km, &i__2, &c_b9, &ab_ref(kv + 2, j), &c__1, & - ab_ref(kv, j + 1), &i__3, &ab_ref(kv + 1, j + 1), - &i__4); - } - } - } else { - -/* If pivot is zero, set INFO to the index of the pivot - unless a zero pivot has already been found. */ - - if (*info == 0) { - *info = j; - } - } -/* L40: */ - } - return 0; - -/* End of DGBTF2 */ - -} /* dgbtf2_ */ - -#undef ab_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgbtrf.c b/ext/f2c_lapack/dgbtrf.c deleted file mode 100644 index fc5323f5b..000000000 --- a/ext/f2c_lapack/dgbtrf.c +++ /dev/null @@ -1,570 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgbtrf_(integer *m, integer *n, integer *kl, integer *ku, - doublereal *ab, integer *ldab, integer *ipiv, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - February 29, 1992 - - - Purpose - ======= - - DGBTRF computes an LU factorization of a real m-by-n band matrix A - using partial pivoting with row interchanges. - - This is the blocked version of the algorithm, calling Level 3 BLAS. - - Arguments - ========= - - M (input) INTEGER - The number of rows of the matrix A. M >= 0. - - N (input) INTEGER - The number of columns of the matrix A. N >= 0. - - KL (input) INTEGER - The number of subdiagonals within the band of A. KL >= 0. - - KU (input) INTEGER - The number of superdiagonals within the band of A. KU >= 0. - - AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) - On entry, the matrix A in band storage, in rows KL+1 to - 2*KL+KU+1; rows 1 to KL of the array need not be set. - The j-th column of A is stored in the j-th column of the - array AB as follows: - AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) - - On exit, details of the factorization: U is stored as an - upper triangular band matrix with KL+KU superdiagonals in - rows 1 to KL+KU+1, and the multipliers used during the - factorization are stored in rows KL+KU+2 to 2*KL+KU+1. - See below for further details. - - LDAB (input) INTEGER - The leading dimension of the array AB. LDAB >= 2*KL+KU+1. - - IPIV (output) INTEGER array, dimension (min(M,N)) - The pivot indices; for 1 <= i <= min(M,N), row i of the - matrix was interchanged with row IPIV(i). - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - > 0: if INFO = +i, U(i,i) is exactly zero. The factorization - has been completed, but the factor U is exactly - singular, and division by zero will occur if it is used - to solve a system of equations. - - Further Details - =============== - - The band storage scheme is illustrated by the following example, when - M = N = 6, KL = 2, KU = 1: - - On entry: On exit: - - * * * + + + * * * u14 u25 u36 - * * + + + + * * u13 u24 u35 u46 - * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 - a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 - a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * - a31 a42 a53 a64 * * m31 m42 m53 m64 * * - - Array elements marked * are not used by the routine; elements marked - + need not be set on entry, but are required by the routine to store - elements of U because of fill-in resulting from the row interchanges. - - ===================================================================== - - - KV is the number of superdiagonals in the factor U, allowing for - fill-in - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static integer c__65 = 65; - static doublereal c_b18 = -1.; - static doublereal c_b31 = 1.; - - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; - doublereal d__1; - /* Local variables */ - extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *); - static doublereal temp; - static integer i__, j; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dgemm_(char *, char *, integer *, integer *, integer * - , doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *), dcopy_( - integer *, doublereal *, integer *, doublereal *, integer *), - dswap_(integer *, doublereal *, integer *, doublereal *, integer * - ); - static doublereal work13[4160] /* was [65][64] */, work31[4160] - /* was [65][64] */; - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *); - static integer i2, i3, j2, j3, k2; - extern /* Subroutine */ int dgbtf2_(integer *, integer *, integer *, - integer *, doublereal *, integer *, integer *, integer *); - static integer jb, nb, ii, jj, jm, ip, jp, km, ju, kv; - extern integer idamax_(integer *, doublereal *, integer *); - static integer nw; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *, - integer *, integer *, integer *, integer *); -#define work13_ref(a_1,a_2) work13[(a_2)*65 + a_1 - 66] -#define work31_ref(a_1,a_2) work31[(a_2)*65 + a_1 - 66] -#define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1] - - - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1 * 1; - ab -= ab_offset; - --ipiv; - - /* Function Body */ - kv = *ku + *kl; - -/* Test the input parameters. */ - - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kl < 0) { - *info = -3; - } else if (*ku < 0) { - *info = -4; - } else if (*ldab < *kl + kv + 1) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBTRF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* Determine the block size for this environment */ - - nb = ilaenv_(&c__1, "DGBTRF", " ", m, n, kl, ku, (ftnlen)6, (ftnlen)1); - -/* The block size must not exceed the limit set by the size of the - local arrays WORK13 and WORK31. */ - - nb = min(nb,64); - - if (nb <= 1 || nb > *kl) { - -/* Use unblocked code */ - - dgbtf2_(m, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info); - } else { - -/* Use blocked code - - Zero the superdiagonal elements of the work array WORK13 */ - - i__1 = nb; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - work13_ref(i__, j) = 0.; -/* L10: */ - } -/* L20: */ - } - -/* Zero the subdiagonal elements of the work array WORK31 */ - - i__1 = nb; - for (j = 1; j <= i__1; ++j) { - i__2 = nb; - for (i__ = j + 1; i__ <= i__2; ++i__) { - work31_ref(i__, j) = 0.; -/* L30: */ - } -/* L40: */ - } - -/* Gaussian elimination with partial pivoting - - Set fill-in elements in columns KU+2 to KV to zero */ - - i__1 = min(kv,*n); - for (j = *ku + 2; j <= i__1; ++j) { - i__2 = *kl; - for (i__ = kv - j + 2; i__ <= i__2; ++i__) { - ab_ref(i__, j) = 0.; -/* L50: */ - } -/* L60: */ - } - -/* JU is the index of the last column affected by the current - stage of the factorization */ - - ju = 1; - - i__1 = min(*m,*n); - i__2 = nb; - for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { -/* Computing MIN */ - i__3 = nb, i__4 = min(*m,*n) - j + 1; - jb = min(i__3,i__4); - -/* The active part of the matrix is partitioned - - A11 A12 A13 - A21 A22 A23 - A31 A32 A33 - - Here A11, A21 and A31 denote the current block of JB columns - which is about to be factorized. The number of rows in the - partitioning are JB, I2, I3 respectively, and the numbers - of columns are JB, J2, J3. The superdiagonal elements of A13 - and the subdiagonal elements of A31 lie outside the band. - - Computing MIN */ - i__3 = *kl - jb, i__4 = *m - j - jb + 1; - i2 = min(i__3,i__4); -/* Computing MIN */ - i__3 = jb, i__4 = *m - j - *kl + 1; - i3 = min(i__3,i__4); - -/* J2 and J3 are computed after JU has been updated. - - Factorize the current block of JB columns */ - - i__3 = j + jb - 1; - for (jj = j; jj <= i__3; ++jj) { - -/* Set fill-in elements in column JJ+KV to zero */ - - if (jj + kv <= *n) { - i__4 = *kl; - for (i__ = 1; i__ <= i__4; ++i__) { - ab_ref(i__, jj + kv) = 0.; -/* L70: */ - } - } - -/* Find pivot and test for singularity. KM is the number of - subdiagonal elements in the current column. - - Computing MIN */ - i__4 = *kl, i__5 = *m - jj; - km = min(i__4,i__5); - i__4 = km + 1; - jp = idamax_(&i__4, &ab_ref(kv + 1, jj), &c__1); - ipiv[jj] = jp + jj - j; - if (ab_ref(kv + jp, jj) != 0.) { -/* Computing MAX - Computing MIN */ - i__6 = jj + *ku + jp - 1; - i__4 = ju, i__5 = min(i__6,*n); - ju = max(i__4,i__5); - if (jp != 1) { - -/* Apply interchange to columns J to J+JB-1 */ - - if (jp + jj - 1 < j + *kl) { - - i__4 = *ldab - 1; - i__5 = *ldab - 1; - dswap_(&jb, &ab_ref(kv + 1 + jj - j, j), &i__4, & - ab_ref(kv + jp + jj - j, j), &i__5); - } else { - -/* The interchange affects columns J to JJ-1 of A31 - which are stored in the work array WORK31 */ - - i__4 = jj - j; - i__5 = *ldab - 1; - dswap_(&i__4, &ab_ref(kv + 1 + jj - j, j), &i__5, - &work31_ref(jp + jj - j - *kl, 1), &c__65) - ; - i__4 = j + jb - jj; - i__5 = *ldab - 1; - i__6 = *ldab - 1; - dswap_(&i__4, &ab_ref(kv + 1, jj), &i__5, &ab_ref( - kv + jp, jj), &i__6); - } - } - -/* Compute multipliers */ - - d__1 = 1. / ab_ref(kv + 1, jj); - dscal_(&km, &d__1, &ab_ref(kv + 2, jj), &c__1); - -/* Update trailing submatrix within the band and within - the current block. JM is the index of the last column - which needs to be updated. - - Computing MIN */ - i__4 = ju, i__5 = j + jb - 1; - jm = min(i__4,i__5); - if (jm > jj) { - i__4 = jm - jj; - i__5 = *ldab - 1; - i__6 = *ldab - 1; - dger_(&km, &i__4, &c_b18, &ab_ref(kv + 2, jj), &c__1, - &ab_ref(kv, jj + 1), &i__5, &ab_ref(kv + 1, - jj + 1), &i__6); - } - } else { - -/* If pivot is zero, set INFO to the index of the pivot - unless a zero pivot has already been found. */ - - if (*info == 0) { - *info = jj; - } - } - -/* Copy current column of A31 into the work array WORK31 - - Computing MIN */ - i__4 = jj - j + 1; - nw = min(i__4,i3); - if (nw > 0) { - dcopy_(&nw, &ab_ref(kv + *kl + 1 - jj + j, jj), &c__1, & - work31_ref(1, jj - j + 1), &c__1); - } -/* L80: */ - } - if (j + jb <= *n) { - -/* Apply the row interchanges to the other blocks. - - Computing MIN */ - i__3 = ju - j + 1; - j2 = min(i__3,kv) - jb; -/* Computing MAX */ - i__3 = 0, i__4 = ju - j - kv + 1; - j3 = max(i__3,i__4); - -/* Use DLASWP to apply the row interchanges to A12, A22, and - A32. */ - - i__3 = *ldab - 1; - dlaswp_(&j2, &ab_ref(kv + 1 - jb, j + jb), &i__3, &c__1, &jb, - &ipiv[j], &c__1); - -/* Adjust the pivot indices. */ - - i__3 = j + jb - 1; - for (i__ = j; i__ <= i__3; ++i__) { - ipiv[i__] = ipiv[i__] + j - 1; -/* L90: */ - } - -/* Apply the row interchanges to A13, A23, and A33 - columnwise. */ - - k2 = j - 1 + jb + j2; - i__3 = j3; - for (i__ = 1; i__ <= i__3; ++i__) { - jj = k2 + i__; - i__4 = j + jb - 1; - for (ii = j + i__ - 1; ii <= i__4; ++ii) { - ip = ipiv[ii]; - if (ip != ii) { - temp = ab_ref(kv + 1 + ii - jj, jj); - ab_ref(kv + 1 + ii - jj, jj) = ab_ref(kv + 1 + ip - - jj, jj); - ab_ref(kv + 1 + ip - jj, jj) = temp; - } -/* L100: */ - } -/* L110: */ - } - -/* Update the relevant part of the trailing submatrix */ - - if (j2 > 0) { - -/* Update A12 */ - - i__3 = *ldab - 1; - i__4 = *ldab - 1; - dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j2, - &c_b31, &ab_ref(kv + 1, j), &i__3, &ab_ref(kv + 1 - - jb, j + jb), &i__4); - - if (i2 > 0) { - -/* Update A22 */ - - i__3 = *ldab - 1; - i__4 = *ldab - 1; - i__5 = *ldab - 1; - dgemm_("No transpose", "No transpose", &i2, &j2, &jb, - &c_b18, &ab_ref(kv + 1 + jb, j), &i__3, & - ab_ref(kv + 1 - jb, j + jb), &i__4, &c_b31, & - ab_ref(kv + 1, j + jb), &i__5); - } - - if (i3 > 0) { - -/* Update A32 */ - - i__3 = *ldab - 1; - i__4 = *ldab - 1; - dgemm_("No transpose", "No transpose", &i3, &j2, &jb, - &c_b18, work31, &c__65, &ab_ref(kv + 1 - jb, - j + jb), &i__3, &c_b31, &ab_ref(kv + *kl + 1 - - jb, j + jb), &i__4); - } - } - - if (j3 > 0) { - -/* Copy the lower triangle of A13 into the work array - WORK13 */ - - i__3 = j3; - for (jj = 1; jj <= i__3; ++jj) { - i__4 = jb; - for (ii = jj; ii <= i__4; ++ii) { - work13_ref(ii, jj) = ab_ref(ii - jj + 1, jj + j + - kv - 1); -/* L120: */ - } -/* L130: */ - } - -/* Update A13 in the work array */ - - i__3 = *ldab - 1; - dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j3, - &c_b31, &ab_ref(kv + 1, j), &i__3, work13, &c__65); - - if (i2 > 0) { - -/* Update A23 */ - - i__3 = *ldab - 1; - i__4 = *ldab - 1; - dgemm_("No transpose", "No transpose", &i2, &j3, &jb, - &c_b18, &ab_ref(kv + 1 + jb, j), &i__3, - work13, &c__65, &c_b31, &ab_ref(jb + 1, j + - kv), &i__4); - } - - if (i3 > 0) { - -/* Update A33 */ - - i__3 = *ldab - 1; - dgemm_("No transpose", "No transpose", &i3, &j3, &jb, - &c_b18, work31, &c__65, work13, &c__65, & - c_b31, &ab_ref(*kl + 1, j + kv), &i__3); - } - -/* Copy the lower triangle of A13 back into place */ - - i__3 = j3; - for (jj = 1; jj <= i__3; ++jj) { - i__4 = jb; - for (ii = jj; ii <= i__4; ++ii) { - ab_ref(ii - jj + 1, jj + j + kv - 1) = work13_ref( - ii, jj); -/* L140: */ - } -/* L150: */ - } - } - } else { - -/* Adjust the pivot indices. */ - - i__3 = j + jb - 1; - for (i__ = j; i__ <= i__3; ++i__) { - ipiv[i__] = ipiv[i__] + j - 1; -/* L160: */ - } - } - -/* Partially undo the interchanges in the current block to - restore the upper triangular form of A31 and copy the upper - triangle of A31 back into place */ - - i__3 = j; - for (jj = j + jb - 1; jj >= i__3; --jj) { - jp = ipiv[jj] - jj + 1; - if (jp != 1) { - -/* Apply interchange to columns J to JJ-1 */ - - if (jp + jj - 1 < j + *kl) { - -/* The interchange does not affect A31 */ - - i__4 = jj - j; - i__5 = *ldab - 1; - i__6 = *ldab - 1; - dswap_(&i__4, &ab_ref(kv + 1 + jj - j, j), &i__5, & - ab_ref(kv + jp + jj - j, j), &i__6); - } else { - -/* The interchange does affect A31 */ - - i__4 = jj - j; - i__5 = *ldab - 1; - dswap_(&i__4, &ab_ref(kv + 1 + jj - j, j), &i__5, & - work31_ref(jp + jj - j - *kl, 1), &c__65); - } - } - -/* Copy the current column of A31 back into place - - Computing MIN */ - i__4 = i3, i__5 = jj - j + 1; - nw = min(i__4,i__5); - if (nw > 0) { - dcopy_(&nw, &work31_ref(1, jj - j + 1), &c__1, &ab_ref(kv - + *kl + 1 - jj + j, jj), &c__1); - } -/* L170: */ - } -/* L180: */ - } - } - - return 0; - -/* End of DGBTRF */ - -} /* dgbtrf_ */ - -#undef ab_ref -#undef work31_ref -#undef work13_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgbtrs.c b/ext/f2c_lapack/dgbtrs.c deleted file mode 100644 index 7fe12c63c..000000000 --- a/ext/f2c_lapack/dgbtrs.c +++ /dev/null @@ -1,229 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgbtrs_(char *trans, integer *n, integer *kl, integer * - ku, integer *nrhs, doublereal *ab, integer *ldab, integer *ipiv, - doublereal *b, integer *ldb, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - March 31, 1993 - - - Purpose - ======= - - DGBTRS solves a system of linear equations - A * X = B or A' * X = B - with a general band matrix A using the LU factorization computed - by DGBTRF. - - Arguments - ========= - - TRANS (input) CHARACTER*1 - Specifies the form of the system of equations. - = 'N': A * X = B (No transpose) - = 'T': A'* X = B (Transpose) - = 'C': A'* X = B (Conjugate transpose = Transpose) - - N (input) INTEGER - The order of the matrix A. N >= 0. - - KL (input) INTEGER - The number of subdiagonals within the band of A. KL >= 0. - - KU (input) INTEGER - The number of superdiagonals within the band of A. KU >= 0. - - NRHS (input) INTEGER - The number of right hand sides, i.e., the number of columns - of the matrix B. NRHS >= 0. - - AB (input) DOUBLE PRECISION array, dimension (LDAB,N) - Details of the LU factorization of the band matrix A, as - computed by DGBTRF. U is stored as an upper triangular band - matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and - the multipliers used during the factorization are stored in - rows KL+KU+2 to 2*KL+KU+1. - - LDAB (input) INTEGER - The leading dimension of the array AB. LDAB >= 2*KL+KU+1. - - IPIV (input) INTEGER array, dimension (N) - The pivot indices; for 1 <= i <= N, row i of the matrix was - interchanged with row IPIV(i). - - B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) - On entry, the right hand side matrix B. - On exit, the solution matrix X. - - LDB (input) INTEGER - The leading dimension of the array B. LDB >= max(1,N). - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - - ===================================================================== - - - Test the input parameters. - - Parameter adjustments */ - /* Table of constant values */ - static doublereal c_b7 = -1.; - static integer c__1 = 1; - static doublereal c_b23 = 1.; - - /* System generated locals */ - integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3; - /* Local variables */ - extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *); - static integer i__, j, l; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *), dswap_(integer *, - doublereal *, integer *, doublereal *, integer *), dtbsv_(char *, - char *, char *, integer *, integer *, doublereal *, integer *, - doublereal *, integer *); - static logical lnoti; - static integer kd, lm; - extern /* Subroutine */ int xerbla_(char *, integer *); - static logical notran; -#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] -#define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1] - - - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1 * 1; - ab -= ab_offset; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - - /* Function Body */ - *info = 0; - notran = lsame_(trans, "N"); - if (! notran && ! lsame_(trans, "T") && ! lsame_( - trans, "C")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*kl < 0) { - *info = -3; - } else if (*ku < 0) { - *info = -4; - } else if (*nrhs < 0) { - *info = -5; - } else if (*ldab < (*kl << 1) + *ku + 1) { - *info = -7; - } else if (*ldb < max(1,*n)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGBTRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - - kd = *ku + *kl + 1; - lnoti = *kl > 0; - - if (notran) { - -/* Solve A*X = B. - - Solve L*X = B, overwriting B with X. - - L is represented as a product of permutations and unit lower - triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), - where each transformation L(i) is a rank-one modification of - the identity matrix. */ - - if (lnoti) { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__2 = *kl, i__3 = *n - j; - lm = min(i__2,i__3); - l = ipiv[j]; - if (l != j) { - dswap_(nrhs, &b_ref(l, 1), ldb, &b_ref(j, 1), ldb); - } - dger_(&lm, nrhs, &c_b7, &ab_ref(kd + 1, j), &c__1, &b_ref(j, - 1), ldb, &b_ref(j + 1, 1), ldb); -/* L10: */ - } - } - - i__1 = *nrhs; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Solve U*X = B, overwriting B with X. */ - - i__2 = *kl + *ku; - dtbsv_("Upper", "No transpose", "Non-unit", n, &i__2, &ab[ - ab_offset], ldab, &b_ref(1, i__), &c__1); -/* L20: */ - } - - } else { - -/* Solve A'*X = B. */ - - i__1 = *nrhs; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Solve U'*X = B, overwriting B with X. */ - - i__2 = *kl + *ku; - dtbsv_("Upper", "Transpose", "Non-unit", n, &i__2, &ab[ab_offset], - ldab, &b_ref(1, i__), &c__1); -/* L30: */ - } - -/* Solve L'*X = B, overwriting B with X. */ - - if (lnoti) { - for (j = *n - 1; j >= 1; --j) { -/* Computing MIN */ - i__1 = *kl, i__2 = *n - j; - lm = min(i__1,i__2); - dgemv_("Transpose", &lm, nrhs, &c_b7, &b_ref(j + 1, 1), ldb, & - ab_ref(kd + 1, j), &c__1, &c_b23, &b_ref(j, 1), ldb); - l = ipiv[j]; - if (l != j) { - dswap_(nrhs, &b_ref(l, 1), ldb, &b_ref(j, 1), ldb); - } -/* L40: */ - } - } - } - return 0; - -/* End of DGBTRS */ - -} /* dgbtrs_ */ - -#undef ab_ref -#undef b_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgebak.c b/ext/f2c_lapack/dgebak.c deleted file mode 100644 index 3a31db769..000000000 --- a/ext/f2c_lapack/dgebak.c +++ /dev/null @@ -1,220 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgebak_(char *job, char *side, integer *n, integer *ilo, - integer *ihi, doublereal *scale, integer *m, doublereal *v, integer * - ldv, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - September 30, 1994 - - - Purpose - ======= - - DGEBAK forms the right or left eigenvectors of a real general matrix - by backward transformation on the computed eigenvectors of the - balanced matrix output by DGEBAL. - - Arguments - ========= - - JOB (input) CHARACTER*1 - Specifies the type of backward transformation required: - = 'N', do nothing, return immediately; - = 'P', do backward transformation for permutation only; - = 'S', do backward transformation for scaling only; - = 'B', do backward transformations for both permutation and - scaling. - JOB must be the same as the argument JOB supplied to DGEBAL. - - SIDE (input) CHARACTER*1 - = 'R': V contains right eigenvectors; - = 'L': V contains left eigenvectors. - - N (input) INTEGER - The number of rows of the matrix V. N >= 0. - - ILO (input) INTEGER - IHI (input) INTEGER - The integers ILO and IHI determined by DGEBAL. - 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. - - SCALE (input) DOUBLE PRECISION array, dimension (N) - Details of the permutation and scaling factors, as returned - by DGEBAL. - - M (input) INTEGER - The number of columns of the matrix V. M >= 0. - - V (input/output) DOUBLE PRECISION array, dimension (LDV,M) - On entry, the matrix of right or left eigenvectors to be - transformed, as returned by DHSEIN or DTREVC. - On exit, V is overwritten by the transformed eigenvectors. - - LDV (input) INTEGER - The leading dimension of the array V. LDV >= max(1,N). - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value. - - ===================================================================== - - - Decode and Test the input parameters - - Parameter adjustments */ - /* System generated locals */ - integer v_dim1, v_offset, i__1; - /* Local variables */ - static integer i__, k; - static doublereal s; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, - doublereal *, integer *); - static logical leftv; - static integer ii; - extern /* Subroutine */ int xerbla_(char *, integer *); - static logical rightv; -#define v_ref(a_1,a_2) v[(a_2)*v_dim1 + a_1] - - --scale; - v_dim1 = *ldv; - v_offset = 1 + v_dim1 * 1; - v -= v_offset; - - /* Function Body */ - rightv = lsame_(side, "R"); - leftv = lsame_(side, "L"); - - *info = 0; - if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") - && ! lsame_(job, "B")) { - *info = -1; - } else if (! rightv && ! leftv) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*ilo < 1 || *ilo > max(1,*n)) { - *info = -4; - } else if (*ihi < min(*ilo,*n) || *ihi > *n) { - *info = -5; - } else if (*m < 0) { - *info = -7; - } else if (*ldv < max(1,*n)) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEBAK", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - if (*m == 0) { - return 0; - } - if (lsame_(job, "N")) { - return 0; - } - - if (*ilo == *ihi) { - goto L30; - } - -/* Backward balance */ - - if (lsame_(job, "S") || lsame_(job, "B")) { - - if (rightv) { - i__1 = *ihi; - for (i__ = *ilo; i__ <= i__1; ++i__) { - s = scale[i__]; - dscal_(m, &s, &v_ref(i__, 1), ldv); -/* L10: */ - } - } - - if (leftv) { - i__1 = *ihi; - for (i__ = *ilo; i__ <= i__1; ++i__) { - s = 1. / scale[i__]; - dscal_(m, &s, &v_ref(i__, 1), ldv); -/* L20: */ - } - } - - } - -/* Backward permutation - - For I = ILO-1 step -1 until 1, - IHI+1 step 1 until N do -- */ - -L30: - if (lsame_(job, "P") || lsame_(job, "B")) { - if (rightv) { - i__1 = *n; - for (ii = 1; ii <= i__1; ++ii) { - i__ = ii; - if (i__ >= *ilo && i__ <= *ihi) { - goto L40; - } - if (i__ < *ilo) { - i__ = *ilo - ii; - } - k = (integer) scale[i__]; - if (k == i__) { - goto L40; - } - dswap_(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv); -L40: - ; - } - } - - if (leftv) { - i__1 = *n; - for (ii = 1; ii <= i__1; ++ii) { - i__ = ii; - if (i__ >= *ilo && i__ <= *ihi) { - goto L50; - } - if (i__ < *ilo) { - i__ = *ilo - ii; - } - k = (integer) scale[i__]; - if (k == i__) { - goto L50; - } - dswap_(m, &v_ref(i__, 1), ldv, &v_ref(k, 1), ldv); -L50: - ; - } - } - } - - return 0; - -/* End of DGEBAK */ - -} /* dgebak_ */ - -#undef v_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgebal.c b/ext/f2c_lapack/dgebal.c deleted file mode 100644 index a3b8758d9..000000000 --- a/ext/f2c_lapack/dgebal.c +++ /dev/null @@ -1,386 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgebal_(char *job, integer *n, doublereal *a, integer * - lda, integer *ilo, integer *ihi, doublereal *scale, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1999 - - - Purpose - ======= - - DGEBAL balances a general real matrix A. This involves, first, - permuting A by a similarity transformation to isolate eigenvalues - in the first 1 to ILO-1 and last IHI+1 to N elements on the - diagonal; and second, applying a diagonal similarity transformation - to rows and columns ILO to IHI to make the rows and columns as - close in norm as possible. Both steps are optional. - - Balancing may reduce the 1-norm of the matrix, and improve the - accuracy of the computed eigenvalues and/or eigenvectors. - - Arguments - ========= - - JOB (input) CHARACTER*1 - Specifies the operations to be performed on A: - = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 - for i = 1,...,N; - = 'P': permute only; - = 'S': scale only; - = 'B': both permute and scale. - - N (input) INTEGER - The order of the matrix A. N >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the input matrix A. - On exit, A is overwritten by the balanced matrix. - If JOB = 'N', A is not referenced. - See Further Details. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,N). - - ILO (output) INTEGER - IHI (output) INTEGER - ILO and IHI are set to integers such that on exit - A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. - If JOB = 'N' or 'S', ILO = 1 and IHI = N. - - SCALE (output) DOUBLE PRECISION array, dimension (N) - Details of the permutations and scaling factors applied to - A. If P(j) is the index of the row and column interchanged - with row and column j and D(j) is the scaling factor - applied to row and column j, then - SCALE(j) = P(j) for j = 1,...,ILO-1 - = D(j) for j = ILO,...,IHI - = P(j) for j = IHI+1,...,N. - The order in which the interchanges are made is N to IHI+1, - then 1 to ILO-1. - - INFO (output) INTEGER - = 0: successful exit. - < 0: if INFO = -i, the i-th argument had an illegal value. - - Further Details - =============== - - The permutations consist of row and column interchanges which put - the matrix in the form - - ( T1 X Y ) - P A P = ( 0 B Z ) - ( 0 0 T2 ) - - where T1 and T2 are upper triangular matrices whose eigenvalues lie - along the diagonal. The column indices ILO and IHI mark the starting - and ending columns of the submatrix B. Balancing consists of applying - a diagonal similarity transformation inv(D) * B * D to make the - 1-norms of each row of B and its corresponding column nearly equal. - The output matrix is - - ( T1 X*D Y ) - ( 0 inv(D)*B*D inv(D)*Z ). - ( 0 0 T2 ) - - Information about the permutations P and the diagonal matrix D is - returned in the vector SCALE. - - This subroutine is based on the EISPACK routine BALANC. - - Modified by Tzu-Yi Chen, Computer Science Division, University of - California at Berkeley, USA - - ===================================================================== - - - Test the input parameters - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - doublereal d__1, d__2; - /* Local variables */ - static integer iexc; - static doublereal c__, f, g; - static integer i__, j, k, l, m; - static doublereal r__, s; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, - doublereal *, integer *); - static doublereal sfmin1, sfmin2, sfmax1, sfmax2, ca, ra; - extern doublereal dlamch_(char *); - extern integer idamax_(integer *, doublereal *, integer *); - extern /* Subroutine */ int xerbla_(char *, integer *); - static logical noconv; - static integer ica, ira; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --scale; - - /* Function Body */ - *info = 0; - if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") - && ! lsame_(job, "B")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEBAL", &i__1); - return 0; - } - - k = 1; - l = *n; - - if (*n == 0) { - goto L210; - } - - if (lsame_(job, "N")) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - scale[i__] = 1.; -/* L10: */ - } - goto L210; - } - - if (lsame_(job, "S")) { - goto L120; - } - -/* Permutation to isolate eigenvalues if possible */ - - goto L50; - -/* Row and column exchange. */ - -L20: - scale[m] = (doublereal) j; - if (j == m) { - goto L30; - } - - dswap_(&l, &a_ref(1, j), &c__1, &a_ref(1, m), &c__1); - i__1 = *n - k + 1; - dswap_(&i__1, &a_ref(j, k), lda, &a_ref(m, k), lda); - -L30: - switch (iexc) { - case 1: goto L40; - case 2: goto L80; - } - -/* Search for rows isolating an eigenvalue and push them down. */ - -L40: - if (l == 1) { - goto L210; - } - --l; - -L50: - for (j = l; j >= 1; --j) { - - i__1 = l; - for (i__ = 1; i__ <= i__1; ++i__) { - if (i__ == j) { - goto L60; - } - if (a_ref(j, i__) != 0.) { - goto L70; - } -L60: - ; - } - - m = l; - iexc = 1; - goto L20; -L70: - ; - } - - goto L90; - -/* Search for columns isolating an eigenvalue and push them left. */ - -L80: - ++k; - -L90: - i__1 = l; - for (j = k; j <= i__1; ++j) { - - i__2 = l; - for (i__ = k; i__ <= i__2; ++i__) { - if (i__ == j) { - goto L100; - } - if (a_ref(i__, j) != 0.) { - goto L110; - } -L100: - ; - } - - m = k; - iexc = 2; - goto L20; -L110: - ; - } - -L120: - i__1 = l; - for (i__ = k; i__ <= i__1; ++i__) { - scale[i__] = 1.; -/* L130: */ - } - - if (lsame_(job, "P")) { - goto L210; - } - -/* Balance the submatrix in rows K to L. - - Iterative loop for norm reduction */ - - sfmin1 = dlamch_("S") / dlamch_("P"); - sfmax1 = 1. / sfmin1; - sfmin2 = sfmin1 * 8.; - sfmax2 = 1. / sfmin2; -L140: - noconv = FALSE_; - - i__1 = l; - for (i__ = k; i__ <= i__1; ++i__) { - c__ = 0.; - r__ = 0.; - - i__2 = l; - for (j = k; j <= i__2; ++j) { - if (j == i__) { - goto L150; - } - c__ += (d__1 = a_ref(j, i__), abs(d__1)); - r__ += (d__1 = a_ref(i__, j), abs(d__1)); -L150: - ; - } - ica = idamax_(&l, &a_ref(1, i__), &c__1); - ca = (d__1 = a_ref(ica, i__), abs(d__1)); - i__2 = *n - k + 1; - ira = idamax_(&i__2, &a_ref(i__, k), lda); - ra = (d__1 = a_ref(i__, ira + k - 1), abs(d__1)); - -/* Guard against zero C or R due to underflow. */ - - if (c__ == 0. || r__ == 0.) { - goto L200; - } - g = r__ / 8.; - f = 1.; - s = c__ + r__; -L160: -/* Computing MAX */ - d__1 = max(f,c__); -/* Computing MIN */ - d__2 = min(r__,g); - if (c__ >= g || max(d__1,ca) >= sfmax2 || min(d__2,ra) <= sfmin2) { - goto L170; - } - f *= 8.; - c__ *= 8.; - ca *= 8.; - r__ /= 8.; - g /= 8.; - ra /= 8.; - goto L160; - -L170: - g = c__ / 8.; -L180: -/* Computing MIN */ - d__1 = min(f,c__), d__1 = min(d__1,g); - if (g < r__ || max(r__,ra) >= sfmax2 || min(d__1,ca) <= sfmin2) { - goto L190; - } - f /= 8.; - c__ /= 8.; - g /= 8.; - ca /= 8.; - r__ *= 8.; - ra *= 8.; - goto L180; - -/* Now balance. */ - -L190: - if (c__ + r__ >= s * .95) { - goto L200; - } - if (f < 1. && scale[i__] < 1.) { - if (f * scale[i__] <= sfmin1) { - goto L200; - } - } - if (f > 1. && scale[i__] > 1.) { - if (scale[i__] >= sfmax1 / f) { - goto L200; - } - } - g = 1. / f; - scale[i__] *= f; - noconv = TRUE_; - - i__2 = *n - k + 1; - dscal_(&i__2, &g, &a_ref(i__, k), lda); - dscal_(&l, &f, &a_ref(1, i__), &c__1); - -L200: - ; - } - - if (noconv) { - goto L140; - } - -L210: - *ilo = k; - *ihi = l; - - return 0; - -/* End of DGEBAL */ - -} /* dgebal_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgebd2.c b/ext/f2c_lapack/dgebd2.c deleted file mode 100644 index 5fd3b976b..000000000 --- a/ext/f2c_lapack/dgebd2.c +++ /dev/null @@ -1,284 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgebd2_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal * - taup, doublereal *work, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - February 29, 1992 - - - Purpose - ======= - - DGEBD2 reduces a real general m by n matrix A to upper or lower - bidiagonal form B by an orthogonal transformation: Q' * A * P = B. - - If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. - - Arguments - ========= - - M (input) INTEGER - The number of rows in the matrix A. M >= 0. - - N (input) INTEGER - The number of columns in the matrix A. N >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the m by n general matrix to be reduced. - On exit, - if m >= n, the diagonal and the first superdiagonal are - overwritten with the upper bidiagonal matrix B; the - elements below the diagonal, with the array TAUQ, represent - the orthogonal matrix Q as a product of elementary - reflectors, and the elements above the first superdiagonal, - with the array TAUP, represent the orthogonal matrix P as - a product of elementary reflectors; - if m < n, the diagonal and the first subdiagonal are - overwritten with the lower bidiagonal matrix B; the - elements below the first subdiagonal, with the array TAUQ, - represent the orthogonal matrix Q as a product of - elementary reflectors, and the elements above the diagonal, - with the array TAUP, represent the orthogonal matrix P as - a product of elementary reflectors. - See Further Details. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - D (output) DOUBLE PRECISION array, dimension (min(M,N)) - The diagonal elements of the bidiagonal matrix B: - D(i) = A(i,i). - - E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) - The off-diagonal elements of the bidiagonal matrix B: - if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; - if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. - - TAUQ (output) DOUBLE PRECISION array dimension (min(M,N)) - The scalar factors of the elementary reflectors which - represent the orthogonal matrix Q. See Further Details. - - TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) - The scalar factors of the elementary reflectors which - represent the orthogonal matrix P. See Further Details. - - WORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) - - INFO (output) INTEGER - = 0: successful exit. - < 0: if INFO = -i, the i-th argument had an illegal value. - - Further Details - =============== - - The matrices Q and P are represented as products of elementary - reflectors: - - If m >= n, - - Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) - - Each H(i) and G(i) has the form: - - H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' - - where tauq and taup are real scalars, and v and u are real vectors; - v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); - u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); - tauq is stored in TAUQ(i) and taup in TAUP(i). - - If m < n, - - Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) - - Each H(i) and G(i) has the form: - - H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' - - where tauq and taup are real scalars, and v and u are real vectors; - v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); - u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); - tauq is stored in TAUQ(i) and taup in TAUP(i). - - The contents of A on exit are illustrated by the following examples: - - m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): - - ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) - ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) - ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) - ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) - ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) - ( v1 v2 v3 v4 v5 ) - - where d and e denote diagonal and off-diagonal elements of B, vi - denotes an element of the vector defining H(i), and ui an element of - the vector defining G(i). - - ===================================================================== - - - Test the input parameters - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - /* Local variables */ - static integer i__; - extern /* Subroutine */ int dlarf_(char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - doublereal *), dlarfg_(integer *, doublereal *, - doublereal *, integer *, doublereal *), xerbla_(char *, integer *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --d__; - --e; - --tauq; - --taup; - --work; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*m)) { - *info = -4; - } - if (*info < 0) { - i__1 = -(*info); - xerbla_("DGEBD2", &i__1); - return 0; - } - - if (*m >= *n) { - -/* Reduce to upper bidiagonal form */ - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) - - Computing MIN */ - i__2 = i__ + 1; - i__3 = *m - i__ + 1; - dlarfg_(&i__3, &a_ref(i__, i__), &a_ref(min(i__2,*m), i__), &c__1, - &tauq[i__]); - d__[i__] = a_ref(i__, i__); - a_ref(i__, i__) = 1.; - -/* Apply H(i) to A(i:m,i+1:n) from the left */ - - i__2 = *m - i__ + 1; - i__3 = *n - i__; - dlarf_("Left", &i__2, &i__3, &a_ref(i__, i__), &c__1, &tauq[i__], - &a_ref(i__, i__ + 1), lda, &work[1]); - a_ref(i__, i__) = d__[i__]; - - if (i__ < *n) { - -/* Generate elementary reflector G(i) to annihilate - A(i,i+2:n) - - Computing MIN */ - i__2 = i__ + 2; - i__3 = *n - i__; - dlarfg_(&i__3, &a_ref(i__, i__ + 1), &a_ref(i__, min(i__2,*n)) - , lda, &taup[i__]); - e[i__] = a_ref(i__, i__ + 1); - a_ref(i__, i__ + 1) = 1.; - -/* Apply G(i) to A(i+1:m,i+1:n) from the right */ - - i__2 = *m - i__; - i__3 = *n - i__; - dlarf_("Right", &i__2, &i__3, &a_ref(i__, i__ + 1), lda, & - taup[i__], &a_ref(i__ + 1, i__ + 1), lda, &work[1]); - a_ref(i__, i__ + 1) = e[i__]; - } else { - taup[i__] = 0.; - } -/* L10: */ - } - } else { - -/* Reduce to lower bidiagonal form */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Generate elementary reflector G(i) to annihilate A(i,i+1:n) - - Computing MIN */ - i__2 = i__ + 1; - i__3 = *n - i__ + 1; - dlarfg_(&i__3, &a_ref(i__, i__), &a_ref(i__, min(i__2,*n)), lda, & - taup[i__]); - d__[i__] = a_ref(i__, i__); - a_ref(i__, i__) = 1.; - -/* Apply G(i) to A(i+1:m,i:n) from the right - - Computing MIN */ - i__2 = i__ + 1; - i__3 = *m - i__; - i__4 = *n - i__ + 1; - dlarf_("Right", &i__3, &i__4, &a_ref(i__, i__), lda, &taup[i__], & - a_ref(min(i__2,*m), i__), lda, &work[1]); - a_ref(i__, i__) = d__[i__]; - - if (i__ < *m) { - -/* Generate elementary reflector H(i) to annihilate - A(i+2:m,i) - - Computing MIN */ - i__2 = i__ + 2; - i__3 = *m - i__; - dlarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(min(i__2,*m), i__) - , &c__1, &tauq[i__]); - e[i__] = a_ref(i__ + 1, i__); - a_ref(i__ + 1, i__) = 1.; - -/* Apply H(i) to A(i+1:m,i+1:n) from the left */ - - i__2 = *m - i__; - i__3 = *n - i__; - dlarf_("Left", &i__2, &i__3, &a_ref(i__ + 1, i__), &c__1, & - tauq[i__], &a_ref(i__ + 1, i__ + 1), lda, &work[1]); - a_ref(i__ + 1, i__) = e[i__]; - } else { - tauq[i__] = 0.; - } -/* L20: */ - } - } - return 0; - -/* End of DGEBD2 */ - -} /* dgebd2_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgebrd.c b/ext/f2c_lapack/dgebrd.c deleted file mode 100644 index d64f3d8e7..000000000 --- a/ext/f2c_lapack/dgebrd.c +++ /dev/null @@ -1,326 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgebrd_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *d__, doublereal *e, doublereal *tauq, doublereal * - taup, doublereal *work, integer *lwork, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1999 - - - Purpose - ======= - - DGEBRD reduces a general real M-by-N matrix A to upper or lower - bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. - - If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. - - Arguments - ========= - - M (input) INTEGER - The number of rows in the matrix A. M >= 0. - - N (input) INTEGER - The number of columns in the matrix A. N >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the M-by-N general matrix to be reduced. - On exit, - if m >= n, the diagonal and the first superdiagonal are - overwritten with the upper bidiagonal matrix B; the - elements below the diagonal, with the array TAUQ, represent - the orthogonal matrix Q as a product of elementary - reflectors, and the elements above the first superdiagonal, - with the array TAUP, represent the orthogonal matrix P as - a product of elementary reflectors; - if m < n, the diagonal and the first subdiagonal are - overwritten with the lower bidiagonal matrix B; the - elements below the first subdiagonal, with the array TAUQ, - represent the orthogonal matrix Q as a product of - elementary reflectors, and the elements above the diagonal, - with the array TAUP, represent the orthogonal matrix P as - a product of elementary reflectors. - See Further Details. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - D (output) DOUBLE PRECISION array, dimension (min(M,N)) - The diagonal elements of the bidiagonal matrix B: - D(i) = A(i,i). - - E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) - The off-diagonal elements of the bidiagonal matrix B: - if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; - if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. - - TAUQ (output) DOUBLE PRECISION array dimension (min(M,N)) - The scalar factors of the elementary reflectors which - represent the orthogonal matrix Q. See Further Details. - - TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) - The scalar factors of the elementary reflectors which - represent the orthogonal matrix P. See Further Details. - - WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - - LWORK (input) INTEGER - The length of the array WORK. LWORK >= max(1,M,N). - For optimum performance LWORK >= (M+N)*NB, where NB - is the optimal blocksize. - - If LWORK = -1, then a workspace query is assumed; the routine - only calculates the optimal size of the WORK array, returns - this value as the first entry of the WORK array, and no error - message related to LWORK is issued by XERBLA. - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value. - - Further Details - =============== - - The matrices Q and P are represented as products of elementary - reflectors: - - If m >= n, - - Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) - - Each H(i) and G(i) has the form: - - H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' - - where tauq and taup are real scalars, and v and u are real vectors; - v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); - u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); - tauq is stored in TAUQ(i) and taup in TAUP(i). - - If m < n, - - Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) - - Each H(i) and G(i) has the form: - - H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' - - where tauq and taup are real scalars, and v and u are real vectors; - v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); - u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); - tauq is stored in TAUQ(i) and taup in TAUP(i). - - The contents of A on exit are illustrated by the following examples: - - m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): - - ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) - ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) - ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) - ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) - ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) - ( v1 v2 v3 v4 v5 ) - - where d and e denote diagonal and off-diagonal elements of B, vi - denotes an element of the vector defining H(i), and ui an element of - the vector defining G(i). - - ===================================================================== - - - Test the input parameters - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static integer c_n1 = -1; - static integer c__3 = 3; - static integer c__2 = 2; - static doublereal c_b21 = -1.; - static doublereal c_b22 = 1.; - - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - /* Local variables */ - static integer i__, j; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *); - static integer nbmin, iinfo, minmn; - extern /* Subroutine */ int dgebd2_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *); - static integer nb; - extern /* Subroutine */ int dlabrd_(integer *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, integer *, doublereal *, integer *); - static integer nx; - static doublereal ws; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - static integer ldwrkx, ldwrky, lwkopt; - static logical lquery; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --d__; - --e; - --tauq; - --taup; - --work; - - /* Function Body */ - *info = 0; -/* Computing MAX */ - i__1 = 1, i__2 = ilaenv_(&c__1, "DGEBRD", " ", m, n, &c_n1, &c_n1, ( - ftnlen)6, (ftnlen)1); - nb = max(i__1,i__2); - lwkopt = (*m + *n) * nb; - work[1] = (doublereal) lwkopt; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*m)) { - *info = -4; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = max(1,*m); - if (*lwork < max(i__1,*n) && ! lquery) { - *info = -10; - } - } - if (*info < 0) { - i__1 = -(*info); - xerbla_("DGEBRD", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - minmn = min(*m,*n); - if (minmn == 0) { - work[1] = 1.; - return 0; - } - - ws = (doublereal) max(*m,*n); - ldwrkx = *m; - ldwrky = *n; - - if (nb > 1 && nb < minmn) { - -/* Set the crossover point NX. - - Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__3, "DGEBRD", " ", m, n, &c_n1, &c_n1, ( - ftnlen)6, (ftnlen)1); - nx = max(i__1,i__2); - -/* Determine when to switch from blocked to unblocked code. */ - - if (nx < minmn) { - ws = (doublereal) ((*m + *n) * nb); - if ((doublereal) (*lwork) < ws) { - -/* Not enough work space for the optimal NB, consider using - a smaller block size. */ - - nbmin = ilaenv_(&c__2, "DGEBRD", " ", m, n, &c_n1, &c_n1, ( - ftnlen)6, (ftnlen)1); - if (*lwork >= (*m + *n) * nbmin) { - nb = *lwork / (*m + *n); - } else { - nb = 1; - nx = minmn; - } - } - } - } else { - nx = minmn; - } - - i__1 = minmn - nx; - i__2 = nb; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - -/* Reduce rows and columns i:i+nb-1 to bidiagonal form and return - the matrices X and Y which are needed to update the unreduced - part of the matrix */ - - i__3 = *m - i__ + 1; - i__4 = *n - i__ + 1; - dlabrd_(&i__3, &i__4, &nb, &a_ref(i__, i__), lda, &d__[i__], &e[i__], - &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx * nb - + 1], &ldwrky); - -/* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update - of the form A := A - V*Y' - X*U' */ - - i__3 = *m - i__ - nb + 1; - i__4 = *n - i__ - nb + 1; - dgemm_("No transpose", "Transpose", &i__3, &i__4, &nb, &c_b21, &a_ref( - i__ + nb, i__), lda, &work[ldwrkx * nb + nb + 1], &ldwrky, & - c_b22, &a_ref(i__ + nb, i__ + nb), lda) - ; - i__3 = *m - i__ - nb + 1; - i__4 = *n - i__ - nb + 1; - dgemm_("No transpose", "No transpose", &i__3, &i__4, &nb, &c_b21, & - work[nb + 1], &ldwrkx, &a_ref(i__, i__ + nb), lda, &c_b22, & - a_ref(i__ + nb, i__ + nb), lda); - -/* Copy diagonal and off-diagonal elements of B back into A */ - - if (*m >= *n) { - i__3 = i__ + nb - 1; - for (j = i__; j <= i__3; ++j) { - a_ref(j, j) = d__[j]; - a_ref(j, j + 1) = e[j]; -/* L10: */ - } - } else { - i__3 = i__ + nb - 1; - for (j = i__; j <= i__3; ++j) { - a_ref(j, j) = d__[j]; - a_ref(j + 1, j) = e[j]; -/* L20: */ - } - } -/* L30: */ - } - -/* Use unblocked code to reduce the remainder of the matrix */ - - i__2 = *m - i__ + 1; - i__1 = *n - i__ + 1; - dgebd2_(&i__2, &i__1, &a_ref(i__, i__), lda, &d__[i__], &e[i__], &tauq[ - i__], &taup[i__], &work[1], &iinfo); - work[1] = ws; - return 0; - -/* End of DGEBRD */ - -} /* dgebrd_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgecon.c b/ext/f2c_lapack/dgecon.c deleted file mode 100644 index 277e922af..000000000 --- a/ext/f2c_lapack/dgecon.c +++ /dev/null @@ -1,228 +0,0 @@ -/* dgecon.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dgecon_(char *norm, integer *n, doublereal *a, integer * - lda, doublereal *anorm, doublereal *rcond, doublereal *work, integer * - iwork, integer *info, ftnlen norm_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1; - doublereal d__1; - - /* Local variables */ - static doublereal sl; - static integer ix; - static doublereal su; - static integer kase, kase1; - static doublereal scale; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *, - integer *); - extern doublereal dlamch_(char *, ftnlen); - extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - extern integer idamax_(integer *, doublereal *, integer *); - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - static doublereal ainvnm; - extern /* Subroutine */ int dlatrs_(char *, char *, char *, char *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); - static logical onenrm; - static char normin[1]; - static doublereal smlnum; - - -/* -- LAPACK routine (version 3.0) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ -/* Courant Institute, Argonne National Lab, and Rice University */ -/* February 29, 1992 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGECON estimates the reciprocal of the condition number of a general */ -/* real matrix A, in either the 1-norm or the infinity-norm, using */ -/* the LU factorization computed by DGETRF. */ - -/* An estimate is obtained for norm(inv(A)), and the reciprocal of the */ -/* condition number is computed as */ -/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies whether the 1-norm condition number or the */ -/* infinity-norm condition number is required: */ -/* = '1' or 'O': 1-norm; */ -/* = 'I': Infinity-norm. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The factors L and U from the factorization A = P*L*U */ -/* as computed by DGETRF. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* ANORM (input) DOUBLE PRECISION */ -/* If NORM = '1' or 'O', the 1-norm of the original matrix A. */ -/* If NORM = 'I', the infinity-norm of the original matrix A. */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The reciprocal of the condition number of the matrix A, */ -/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --work; - --iwork; - - /* Function Body */ - *info = 0; - onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O", (ftnlen)1, ( - ftnlen)1); - if (! onenrm && ! lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } else if (*anorm < 0.) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGECON", &i__1, (ftnlen)6); - return 0; - } - -/* Quick return if possible */ - - *rcond = 0.; - if (*n == 0) { - *rcond = 1.; - return 0; - } else if (*anorm == 0.) { - return 0; - } - - smlnum = dlamch_("Safe minimum", (ftnlen)12); - -/* Estimate the norm of inv(A). */ - - ainvnm = 0.; - *(unsigned char *)normin = 'N'; - if (onenrm) { - kase1 = 1; - } else { - kase1 = 2; - } - kase = 0; -L10: - dlacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase); - if (kase != 0) { - if (kase == kase1) { - -/* Multiply by inv(L). */ - - dlatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset], - lda, &work[1], &sl, &work[(*n << 1) + 1], info, (ftnlen)5, - (ftnlen)12, (ftnlen)4, (ftnlen)1); - -/* Multiply by inv(U). */ - - dlatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[ - a_offset], lda, &work[1], &su, &work[*n * 3 + 1], info, ( - ftnlen)5, (ftnlen)12, (ftnlen)8, (ftnlen)1); - } else { - -/* Multiply by inv(U'). */ - - dlatrs_("Upper", "Transpose", "Non-unit", normin, n, &a[a_offset], - lda, &work[1], &su, &work[*n * 3 + 1], info, (ftnlen)5, ( - ftnlen)9, (ftnlen)8, (ftnlen)1); - -/* Multiply by inv(L'). */ - - dlatrs_("Lower", "Transpose", "Unit", normin, n, &a[a_offset], - lda, &work[1], &sl, &work[(*n << 1) + 1], info, (ftnlen)5, - (ftnlen)9, (ftnlen)4, (ftnlen)1); - } - -/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */ - - scale = sl * su; - *(unsigned char *)normin = 'Y'; - if (scale != 1.) { - ix = idamax_(n, &work[1], &c__1); - if (scale < (d__1 = work[ix], abs(d__1)) * smlnum || scale == 0.) - { - goto L20; - } - drscl_(n, &scale, &work[1], &c__1); - } - goto L10; - } - -/* Compute the estimate of the reciprocal condition number. */ - - if (ainvnm != 0.) { - *rcond = 1. / ainvnm / *anorm; - } - -L20: - return 0; - -/* End of DGECON */ - -} /* dgecon_ */ - diff --git a/ext/f2c_lapack/dgeequ.c b/ext/f2c_lapack/dgeequ.c deleted file mode 100644 index 125849ce7..000000000 --- a/ext/f2c_lapack/dgeequ.c +++ /dev/null @@ -1,297 +0,0 @@ -/* dgeequ.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "f2c.h" - -/* Subroutine */ int dgeequ_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, doublereal - *colcnd, doublereal *amax, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - doublereal d__1, d__2, d__3; - - /* Local variables */ - static integer i__, j; - static doublereal rcmin, rcmax; - extern doublereal dlamch_(char *, ftnlen); - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - static doublereal bignum, smlnum; - - -/* -- LAPACK routine (version 3.0) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ -/* Courant Institute, Argonne National Lab, and Rice University */ -/* March 31, 1993 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGEEQU computes row and column scalings intended to equilibrate an */ -/* M-by-N matrix A and reduce its condition number. R returns the row */ -/* scale factors and C the column scale factors, chosen to try to make */ -/* the largest element in each row and column of the matrix B with */ -/* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */ - -/* R(i) and C(j) are restricted to be between SMLNUM = smallest safe */ -/* number and BIGNUM = largest safe number. Use of these scaling */ -/* factors is not guaranteed to reduce the condition number of A but */ -/* works well in practice. */ - -/* Arguments */ -/* ========= */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. M >= 0. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The M-by-N matrix whose equilibration factors are */ -/* to be computed. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,M). */ - -/* R (output) DOUBLE PRECISION array, dimension (M) */ -/* If INFO = 0 or INFO > M, R contains the row scale factors */ -/* for A. */ - -/* C (output) DOUBLE PRECISION array, dimension (N) */ -/* If INFO = 0, C contains the column scale factors for A. */ - -/* ROWCND (output) DOUBLE PRECISION */ -/* If INFO = 0 or INFO > M, ROWCND contains the ratio of the */ -/* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */ -/* AMAX is neither too large nor too small, it is not worth */ -/* scaling by R. */ - -/* COLCND (output) DOUBLE PRECISION */ -/* If INFO = 0, COLCND contains the ratio of the smallest */ -/* C(i) to the largest C(i). If COLCND >= 0.1, it is not */ -/* worth scaling by C. */ - -/* AMAX (output) DOUBLE PRECISION */ -/* Absolute value of largest matrix element. If AMAX is very */ -/* close to overflow or very close to underflow, the matrix */ -/* should be scaled. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, and i is */ -/* <= M: the i-th row of A is exactly zero */ -/* > M: the (i-M)-th column of A is exactly zero */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --r__; - --c__; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*m)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEEQU", &i__1, (ftnlen)6); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - *rowcnd = 1.; - *colcnd = 1.; - *amax = 0.; - return 0; - } - -/* Get machine constants. */ - - smlnum = dlamch_("S", (ftnlen)1); - bignum = 1. / smlnum; - -/* Compute row scale factors. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - r__[i__] = 0.; -/* L10: */ - } - -/* Find the maximum element in each row. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = r__[i__], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)); - r__[i__] = max(d__2,d__3); -/* L20: */ - } -/* L30: */ - } - -/* Find the maximum and minimum scale factors. */ - - rcmin = bignum; - rcmax = 0.; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = rcmax, d__2 = r__[i__]; - rcmax = max(d__1,d__2); -/* Computing MIN */ - d__1 = rcmin, d__2 = r__[i__]; - rcmin = min(d__1,d__2); -/* L40: */ - } - *amax = rcmax; - - if (rcmin == 0.) { - -/* Find the first zero scale factor and return an error code. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (r__[i__] == 0.) { - *info = i__; - return 0; - } -/* L50: */ - } - } else { - -/* Invert the scale factors. */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MIN */ -/* Computing MAX */ - d__2 = r__[i__]; - d__1 = max(d__2,smlnum); - r__[i__] = 1. / min(d__1,bignum); -/* L60: */ - } - -/* Compute ROWCND = min(R(I)) / max(R(I)) */ - - *rowcnd = max(rcmin,smlnum) / min(rcmax,bignum); - } - -/* Compute column scale factors */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - c__[j] = 0.; -/* L70: */ - } - -/* Find the maximum element in each column, */ -/* assuming the row scaling computed above. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = c__[j], d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1)) * - r__[i__]; - c__[j] = max(d__2,d__3); -/* L80: */ - } -/* L90: */ - } - -/* Find the maximum and minimum scale factors. */ - - rcmin = bignum; - rcmax = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - d__1 = rcmin, d__2 = c__[j]; - rcmin = min(d__1,d__2); -/* Computing MAX */ - d__1 = rcmax, d__2 = c__[j]; - rcmax = max(d__1,d__2); -/* L100: */ - } - - if (rcmin == 0.) { - -/* Find the first zero scale factor and return an error code. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (c__[j] == 0.) { - *info = *m + j; - return 0; - } -/* L110: */ - } - } else { - -/* Invert the scale factors. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ -/* Computing MAX */ - d__2 = c__[j]; - d__1 = max(d__2,smlnum); - c__[j] = 1. / min(d__1,bignum); -/* L120: */ - } - -/* Compute COLCND = min(C(J)) / max(C(J)) */ - - *colcnd = max(rcmin,smlnum) / min(rcmax,bignum); - } - - return 0; - -/* End of DGEEQU */ - -} /* dgeequ_ */ - diff --git a/ext/f2c_lapack/dgelq2.c b/ext/f2c_lapack/dgelq2.c deleted file mode 100644 index d731d836e..000000000 --- a/ext/f2c_lapack/dgelq2.c +++ /dev/null @@ -1,142 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgelq2_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - February 29, 1992 - - - Purpose - ======= - - DGELQ2 computes an LQ factorization of a real m by n matrix A: - A = L * Q. - - Arguments - ========= - - M (input) INTEGER - The number of rows of the matrix A. M >= 0. - - N (input) INTEGER - The number of columns of the matrix A. N >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the m by n matrix A. - On exit, the elements on and below the diagonal of the array - contain the m by min(m,n) lower trapezoidal matrix L (L is - lower triangular if m <= n); the elements above the diagonal, - with the array TAU, represent the orthogonal matrix Q as a - product of elementary reflectors (see Further Details). - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) - The scalar factors of the elementary reflectors (see Further - Details). - - WORK (workspace) DOUBLE PRECISION array, dimension (M) - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - - Further Details - =============== - - The matrix Q is represented as a product of elementary reflectors - - Q = H(k) . . . H(2) H(1), where k = min(m,n). - - Each H(i) has the form - - H(i) = I - tau * v * v' - - where tau is a real scalar, and v is a real vector with - v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), - and tau in TAU(i). - - ===================================================================== - - - Test the input arguments - - Parameter adjustments */ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - /* Local variables */ - static integer i__, k; - extern /* Subroutine */ int dlarf_(char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - doublereal *), dlarfg_(integer *, doublereal *, - doublereal *, integer *, doublereal *), xerbla_(char *, integer *); - static doublereal aii; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*m)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGELQ2", &i__1); - return 0; - } - - k = min(*m,*n); - - i__1 = k; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Generate elementary reflector H(i) to annihilate A(i,i+1:n) - - Computing MIN */ - i__2 = i__ + 1; - i__3 = *n - i__ + 1; - dlarfg_(&i__3, &a_ref(i__, i__), &a_ref(i__, min(i__2,*n)), lda, &tau[ - i__]); - if (i__ < *m) { - -/* Apply H(i) to A(i+1:m,i:n) from the right */ - - aii = a_ref(i__, i__); - a_ref(i__, i__) = 1.; - i__2 = *m - i__; - i__3 = *n - i__ + 1; - dlarf_("Right", &i__2, &i__3, &a_ref(i__, i__), lda, &tau[i__], & - a_ref(i__ + 1, i__), lda, &work[1]); - a_ref(i__, i__) = aii; - } -/* L10: */ - } - return 0; - -/* End of DGELQ2 */ - -} /* dgelq2_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgelqf.c b/ext/f2c_lapack/dgelqf.c deleted file mode 100644 index 36249cc7a..000000000 --- a/ext/f2c_lapack/dgelqf.c +++ /dev/null @@ -1,242 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgelqf_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *lwork, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1999 - - - Purpose - ======= - - DGELQF computes an LQ factorization of a real M-by-N matrix A: - A = L * Q. - - Arguments - ========= - - M (input) INTEGER - The number of rows of the matrix A. M >= 0. - - N (input) INTEGER - The number of columns of the matrix A. N >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the M-by-N matrix A. - On exit, the elements on and below the diagonal of the array - contain the m-by-min(m,n) lower trapezoidal matrix L (L is - lower triangular if m <= n); the elements above the diagonal, - with the array TAU, represent the orthogonal matrix Q as a - product of elementary reflectors (see Further Details). - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) - The scalar factors of the elementary reflectors (see Further - Details). - - WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - - LWORK (input) INTEGER - The dimension of the array WORK. LWORK >= max(1,M). - For optimum performance LWORK >= M*NB, where NB is the - optimal blocksize. - - If LWORK = -1, then a workspace query is assumed; the routine - only calculates the optimal size of the WORK array, returns - this value as the first entry of the WORK array, and no error - message related to LWORK is issued by XERBLA. - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - - Further Details - =============== - - The matrix Q is represented as a product of elementary reflectors - - Q = H(k) . . . H(2) H(1), where k = min(m,n). - - Each H(i) has the form - - H(i) = I - tau * v * v' - - where tau is a real scalar, and v is a real vector with - v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), - and tau in TAU(i). - - ===================================================================== - - - Test the input arguments - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static integer c_n1 = -1; - static integer c__3 = 3; - static integer c__2 = 2; - - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - /* Local variables */ - static integer i__, k, nbmin, iinfo; - extern /* Subroutine */ int dgelq2_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *); - static integer ib, nb; - extern /* Subroutine */ int dlarfb_(char *, char *, char *, char *, - integer *, integer *, integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *); - static integer nx; - extern /* Subroutine */ int dlarft_(char *, char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - static integer ldwork, lwkopt; - static logical lquery; - static integer iws; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen) - 1); - lwkopt = *m * nb; - work[1] = (doublereal) lwkopt; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*m)) { - *info = -4; - } else if (*lwork < max(1,*m) && ! lquery) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGELQF", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - k = min(*m,*n); - if (k == 0) { - work[1] = 1.; - return 0; - } - - nbmin = 2; - nx = 0; - iws = *m; - if (nb > 1 && nb < k) { - -/* Determine when to cross over from blocked to unblocked code. - - Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, "DGELQF", " ", m, n, &c_n1, &c_n1, ( - ftnlen)6, (ftnlen)1); - nx = max(i__1,i__2); - if (nx < k) { - -/* Determine if workspace is large enough for blocked code. */ - - ldwork = *m; - iws = ldwork * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: reduce NB and - determine the minimum value of NB. */ - - nb = *lwork / ldwork; -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DGELQF", " ", m, n, &c_n1, & - c_n1, (ftnlen)6, (ftnlen)1); - nbmin = max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < k && nx < k) { - -/* Use blocked code initially */ - - i__1 = k - nx; - i__2 = nb; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__3 = k - i__ + 1; - ib = min(i__3,nb); - -/* Compute the LQ factorization of the current block - A(i:i+ib-1,i:n) */ - - i__3 = *n - i__ + 1; - dgelq2_(&ib, &i__3, &a_ref(i__, i__), lda, &tau[i__], &work[1], & - iinfo); - if (i__ + ib <= *m) { - -/* Form the triangular factor of the block reflector - H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__3 = *n - i__ + 1; - dlarft_("Forward", "Rowwise", &i__3, &ib, &a_ref(i__, i__), - lda, &tau[i__], &work[1], &ldwork); - -/* Apply H to A(i+ib:m,i:n) from the right */ - - i__3 = *m - i__ - ib + 1; - i__4 = *n - i__ + 1; - dlarfb_("Right", "No transpose", "Forward", "Rowwise", &i__3, - &i__4, &ib, &a_ref(i__, i__), lda, &work[1], &ldwork, - &a_ref(i__ + ib, i__), lda, &work[ib + 1], &ldwork); - } -/* L10: */ - } - } else { - i__ = 1; - } - -/* Use unblocked code to factor the last or only block. */ - - if (i__ <= k) { - i__2 = *m - i__ + 1; - i__1 = *n - i__ + 1; - dgelq2_(&i__2, &i__1, &a_ref(i__, i__), lda, &tau[i__], &work[1], & - iinfo); - } - - work[1] = (doublereal) iws; - return 0; - -/* End of DGELQF */ - -} /* dgelqf_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgels.c b/ext/f2c_lapack/dgels.c deleted file mode 100644 index 876a9056a..000000000 --- a/ext/f2c_lapack/dgels.c +++ /dev/null @@ -1,480 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgels_(char *trans, integer *m, integer *n, integer * - nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, - doublereal *work, integer *lwork, integer *info) -{ -/* -- LAPACK driver routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1999 - - - Purpose - ======= - - DGELS solves overdetermined or underdetermined real linear systems - involving an M-by-N matrix A, or its transpose, using a QR or LQ - factorization of A. It is assumed that A has full rank. - - The following options are provided: - - 1. If TRANS = 'N' and m >= n: find the least squares solution of - an overdetermined system, i.e., solve the least squares problem - minimize || B - A*X ||. - - 2. If TRANS = 'N' and m < n: find the minimum norm solution of - an underdetermined system A * X = B. - - 3. If TRANS = 'T' and m >= n: find the minimum norm solution of - an undetermined system A**T * X = B. - - 4. If TRANS = 'T' and m < n: find the least squares solution of - an overdetermined system, i.e., solve the least squares problem - minimize || B - A**T * X ||. - - Several right hand side vectors b and solution vectors x can be - handled in a single call; they are stored as the columns of the - M-by-NRHS right hand side matrix B and the N-by-NRHS solution - matrix X. - - Arguments - ========= - - TRANS (input) CHARACTER - = 'N': the linear system involves A; - = 'T': the linear system involves A**T. - - M (input) INTEGER - The number of rows of the matrix A. M >= 0. - - N (input) INTEGER - The number of columns of the matrix A. N >= 0. - - NRHS (input) INTEGER - The number of right hand sides, i.e., the number of - columns of the matrices B and X. NRHS >=0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the M-by-N matrix A. - On exit, - if M >= N, A is overwritten by details of its QR - factorization as returned by DGEQRF; - if M < N, A is overwritten by details of its LQ - factorization as returned by DGELQF. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) - On entry, the matrix B of right hand side vectors, stored - columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS - if TRANS = 'T'. - On exit, B is overwritten by the solution vectors, stored - columnwise: - if TRANS = 'N' and m >= n, rows 1 to n of B contain the least - squares solution vectors; the residual sum of squares for the - solution in each column is given by the sum of squares of - elements N+1 to M in that column; - if TRANS = 'N' and m < n, rows 1 to N of B contain the - minimum norm solution vectors; - if TRANS = 'T' and m >= n, rows 1 to M of B contain the - minimum norm solution vectors; - if TRANS = 'T' and m < n, rows 1 to M of B contain the - least squares solution vectors; the residual sum of squares - for the solution in each column is given by the sum of - squares of elements M+1 to N in that column. - - LDB (input) INTEGER - The leading dimension of the array B. LDB >= MAX(1,M,N). - - WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - - LWORK (input) INTEGER - The dimension of the array WORK. - LWORK >= max( 1, MN + max( MN, NRHS ) ). - For optimal performance, - LWORK >= max( 1, MN + max( MN, NRHS )*NB ). - where MN = min(M,N) and NB is the optimum block size. - - If LWORK = -1, then a workspace query is assumed; the routine - only calculates the optimal size of the WORK array, returns - this value as the first entry of the WORK array, and no error - message related to LWORK is issued by XERBLA. - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - - ===================================================================== - - - Test the input arguments. - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static integer c_n1 = -1; - static doublereal c_b33 = 0.; - static integer c__0 = 0; - static doublereal c_b61 = 1.; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; - /* Local variables */ - static doublereal anrm, bnrm; - static integer brow; - static logical tpsd; - static integer i__, j, iascl, ibscl; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *); - static integer wsize; - static doublereal rwork[1]; - extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); - static integer nb; - extern doublereal dlamch_(char *), dlange_(char *, integer *, - integer *, doublereal *, integer *, doublereal *); - static integer mn; - extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, integer *), - dlascl_(char *, integer *, integer *, doublereal *, doublereal *, - integer *, integer *, doublereal *, integer *, integer *), - dgeqrf_(integer *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, integer *), dlaset_(char *, - integer *, integer *, doublereal *, doublereal *, doublereal *, - integer *), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - static integer scllen; - static doublereal bignum; - extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *), - dormqr_(char *, char *, integer *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, integer *); - static doublereal smlnum; - static logical lquery; -#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - --work; - - /* Function Body */ - *info = 0; - mn = min(*m,*n); - lquery = *lwork == -1; - if (! (lsame_(trans, "N") || lsame_(trans, "T"))) { - *info = -1; - } else if (*m < 0) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*nrhs < 0) { - *info = -4; - } else if (*lda < max(1,*m)) { - *info = -6; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = max(1,*m); - if (*ldb < max(i__1,*n)) { - *info = -8; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = 1, i__2 = mn + max(mn,*nrhs); - if (*lwork < max(i__1,i__2) && ! lquery) { - *info = -10; - } - } - } - -/* Figure out optimal block size */ - - if (*info == 0 || *info == -10) { - - tpsd = TRUE_; - if (lsame_(trans, "N")) { - tpsd = FALSE_; - } - - if (*m >= *n) { - nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, - (ftnlen)1); - if (tpsd) { -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LN", m, nrhs, n, & - c_n1, (ftnlen)6, (ftnlen)2); - nb = max(i__1,i__2); - } else { -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LT", m, nrhs, n, & - c_n1, (ftnlen)6, (ftnlen)2); - nb = max(i__1,i__2); - } - } else { - nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, - (ftnlen)1); - if (tpsd) { -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LT", n, nrhs, m, & - c_n1, (ftnlen)6, (ftnlen)2); - nb = max(i__1,i__2); - } else { -/* Computing MAX */ - i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LN", n, nrhs, m, & - c_n1, (ftnlen)6, (ftnlen)2); - nb = max(i__1,i__2); - } - } - -/* Computing MAX */ - i__1 = 1, i__2 = mn + max(mn,*nrhs) * nb; - wsize = max(i__1,i__2); - work[1] = (doublereal) wsize; - - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGELS ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible - - Computing MIN */ - i__1 = min(*m,*n); - if (min(i__1,*nrhs) == 0) { - i__1 = max(*m,*n); - dlaset_("Full", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb); - return 0; - } - -/* Get machine parameters */ - - smlnum = dlamch_("S") / dlamch_("P"); - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - -/* Scale A, B if max element outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", m, n, &a[a_offset], lda, rwork); - iascl = 0; - if (anrm > 0. && anrm < smlnum) { - -/* Scale matrix norm up to SMLNUM */ - - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, - info); - iascl = 1; - } else if (anrm > bignum) { - -/* Scale matrix norm down to BIGNUM */ - - dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, - info); - iascl = 2; - } else if (anrm == 0.) { - -/* Matrix all zero. Return zero solution. */ - - i__1 = max(*m,*n); - dlaset_("F", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb); - goto L50; - } - - brow = *m; - if (tpsd) { - brow = *n; - } - bnrm = dlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork); - ibscl = 0; - if (bnrm > 0. && bnrm < smlnum) { - -/* Scale matrix norm up to SMLNUM */ - - dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset], - ldb, info); - ibscl = 1; - } else if (bnrm > bignum) { - -/* Scale matrix norm down to BIGNUM */ - - dlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset], - ldb, info); - ibscl = 2; - } - - if (*m >= *n) { - -/* compute QR factorization of A */ - - i__1 = *lwork - mn; - dgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info) - ; - -/* workspace at least N, optimally N*NB */ - - if (! tpsd) { - -/* Least-Squares Problem min || A * X - B || - - B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */ - - i__1 = *lwork - mn; - dormqr_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &work[ - 1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); - -/* workspace at least NRHS, optimally NRHS*NB - - B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */ - - dtrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, & - c_b61, &a[a_offset], lda, &b[b_offset], ldb); - - scllen = *n; - - } else { - -/* Overdetermined system of equations A' * X = B - - B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */ - - dtrsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b61, - &a[a_offset], lda, &b[b_offset], ldb); - -/* B(N+1:M,1:NRHS) = ZERO */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = *n + 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = 0.; -/* L10: */ - } -/* L20: */ - } - -/* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */ - - i__1 = *lwork - mn; - dormqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, & - work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); - -/* workspace at least NRHS, optimally NRHS*NB */ - - scllen = *m; - - } - - } else { - -/* Compute LQ factorization of A */ - - i__1 = *lwork - mn; - dgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info) - ; - -/* workspace at least M, optimally M*NB. */ - - if (! tpsd) { - -/* underdetermined system of equations A * X = B - - B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */ - - dtrsm_("Left", "Lower", "No transpose", "Non-unit", m, nrhs, & - c_b61, &a[a_offset], lda, &b[b_offset], ldb); - -/* B(M+1:N,1:NRHS) = 0 */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = *m + 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = 0.; -/* L30: */ - } -/* L40: */ - } - -/* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */ - - i__1 = *lwork - mn; - dormlq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &work[ - 1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); - -/* workspace at least NRHS, optimally NRHS*NB */ - - scllen = *n; - - } else { - -/* overdetermined system min || A' * X - B || - - B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */ - - i__1 = *lwork - mn; - dormlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, & - work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); - -/* workspace at least NRHS, optimally NRHS*NB - - B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */ - - dtrsm_("Left", "Lower", "Transpose", "Non-unit", m, nrhs, &c_b61, - &a[a_offset], lda, &b[b_offset], ldb); - - scllen = *m; - - } - - } - -/* Undo scaling */ - - if (iascl == 1) { - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset] - , ldb, info); - } else if (iascl == 2) { - dlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset] - , ldb, info); - } - if (ibscl == 1) { - dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset] - , ldb, info); - } else if (ibscl == 2) { - dlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset] - , ldb, info); - } - -L50: - work[1] = (doublereal) wsize; - - return 0; - -/* End of DGELS */ - -} /* dgels_ */ - -#undef b_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgelss.c b/ext/f2c_lapack/dgelss.c deleted file mode 100644 index 3dd52462d..000000000 --- a/ext/f2c_lapack/dgelss.c +++ /dev/null @@ -1,818 +0,0 @@ -#include "blaswrap.h" -/* -- translated by f2c (version 19990503). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Table of constant values */ - -static integer c__6 = 6; -static integer c_n1 = -1; -static integer c__1 = 1; -static integer c__0 = 0; -static doublereal c_b74 = 0.; -static doublereal c_b108 = 1.; - -/* Subroutine */ int dgelss_(integer *m, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * - s, doublereal *rcond, integer *rank, doublereal *work, integer *lwork, - integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; - doublereal d__1; - - /* Local variables */ - static doublereal anrm, bnrm; - static integer itau; - static doublereal vdum[1]; - static integer i__; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *); - static integer iascl, ibscl; - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *), drscl_(integer *, - doublereal *, doublereal *, integer *); - static integer chunk; - static doublereal sfmin; - static integer minmn; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); - static integer maxmn, itaup, itauq, mnthr, iwork; - extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); - static integer bl, ie, il; - extern /* Subroutine */ int dgebrd_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *, integer *); - extern doublereal dlamch_(char *); - static integer mm; - extern doublereal dlange_(char *, integer *, integer *, doublereal *, - integer *, doublereal *); - static integer bdspac; - extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, integer *), - dlascl_(char *, integer *, integer *, doublereal *, doublereal *, - integer *, integer *, doublereal *, integer *, integer *), - dgeqrf_(integer *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, integer *), dlacpy_(char *, - integer *, integer *, doublereal *, integer *, doublereal *, - integer *), dlaset_(char *, integer *, integer *, - doublereal *, doublereal *, doublereal *, integer *), - xerbla_(char *, integer *), dbdsqr_(char *, integer *, - integer *, integer *, integer *, doublereal *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *, doublereal *, integer *), dorgbr_(char *, - integer *, integer *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, integer *); - static doublereal bignum; - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int dormbr_(char *, char *, char *, integer *, - integer *, integer *, doublereal *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, integer *), dormlq_(char *, char *, integer *, - integer *, integer *, doublereal *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, integer *); - static integer ldwork; - extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *); - static integer minwrk, maxwrk; - static doublereal smlnum; - static logical lquery; - static doublereal eps, thr; - - -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] - - -/* -- LAPACK driver routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1999 - - - Purpose - ======= - - DGELSS computes the minimum norm solution to a real linear least - squares problem: - - Minimize 2-norm(| b - A*x |). - - using the singular value decomposition (SVD) of A. A is an M-by-N - matrix which may be rank-deficient. - - Several right hand side vectors b and solution vectors x can be - handled in a single call; they are stored as the columns of the - M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix - X. - - The effective rank of A is determined by treating as zero those - singular values which are less than RCOND times the largest singular - value. - - Arguments - ========= - - M (input) INTEGER - The number of rows of the matrix A. M >= 0. - - N (input) INTEGER - The number of columns of the matrix A. N >= 0. - - NRHS (input) INTEGER - The number of right hand sides, i.e., the number of columns - of the matrices B and X. NRHS >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the M-by-N matrix A. - On exit, the first min(m,n) rows of A are overwritten with - its right singular vectors, stored rowwise. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) - On entry, the M-by-NRHS right hand side matrix B. - On exit, B is overwritten by the N-by-NRHS solution - matrix X. If m >= n and RANK = n, the residual - sum-of-squares for the solution in the i-th column is given - by the sum of squares of elements n+1:m in that column. - - LDB (input) INTEGER - The leading dimension of the array B. LDB >= max(1,max(M,N)). - - S (output) DOUBLE PRECISION array, dimension (min(M,N)) - The singular values of A in decreasing order. - The condition number of A in the 2-norm = S(1)/S(min(m,n)). - - RCOND (input) DOUBLE PRECISION - RCOND is used to determine the effective rank of A. - Singular values S(i) <= RCOND*S(1) are treated as zero. - If RCOND < 0, machine precision is used instead. - - RANK (output) INTEGER - The effective rank of A, i.e., the number of singular values - which are greater than RCOND*S(1). - - WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - - LWORK (input) INTEGER - The dimension of the array WORK. LWORK >= 1, and also: - LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) - For good performance, LWORK should generally be larger. - - If LWORK = -1, then a workspace query is assumed; the routine - only calculates the optimal size of the WORK array, returns - this value as the first entry of the WORK array, and no error - message related to LWORK is issued by XERBLA. - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value. - > 0: the algorithm for computing the SVD failed to converge; - if INFO = i, i off-diagonal elements of an intermediate - bidiagonal form did not converge to zero. - - ===================================================================== - - - Test the input arguments - - Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - --s; - --work; - - /* Function Body */ - *info = 0; - minmn = min(*m,*n); - maxmn = max(*m,*n); - mnthr = ilaenv_(&c__6, "DGELSS", " ", m, n, nrhs, &c_n1, (ftnlen)6, ( - ftnlen)1); - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < max(1,*m)) { - *info = -5; - } else if (*ldb < max(1,maxmn)) { - *info = -7; - } - -/* Compute workspace - (Note: Comments in the code beginning "Workspace:" describe the - minimal amount of workspace needed at that point in the code, - as well as the preferred amount for good performance. - NB refers to the optimal block size for the immediately - following subroutine, as returned by ILAENV.) */ - - minwrk = 1; - if (*info == 0 && (*lwork >= 1 || lquery)) { - maxwrk = 0; - mm = *m; - if (*m >= *n && *m >= mnthr) { - -/* Path 1a - overdetermined, with many more rows than columns */ - - mm = *n; -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "DGEQRF", " ", m, - n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); - maxwrk = max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "DORMQR", "LT", - m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)2); - maxwrk = max(i__1,i__2); - } - if (*m >= *n) { - -/* Path 1 - overdetermined or exactly determined - - Compute workspace needed for DBDSQR - - Computing MAX */ - i__1 = 1, i__2 = *n * 5; - bdspac = max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + (mm + *n) * ilaenv_(&c__1, "DGEBRD" - , " ", &mm, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); - maxwrk = max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + *nrhs * ilaenv_(&c__1, "DORMBR", - "QLT", &mm, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)3); - maxwrk = max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * 3 + (*n - 1) * ilaenv_(&c__1, "DORGBR", - "P", n, n, n, &c_n1, (ftnlen)6, (ftnlen)1); - maxwrk = max(i__1,i__2); - maxwrk = max(maxwrk,bdspac); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * *nrhs; - maxwrk = max(i__1,i__2); -/* Computing MAX */ - i__1 = *n * 3 + mm, i__2 = *n * 3 + *nrhs, i__1 = max(i__1,i__2); - minwrk = max(i__1,bdspac); - maxwrk = max(minwrk,maxwrk); - } - if (*n > *m) { - -/* Compute workspace needed for DBDSQR - - Computing MAX */ - i__1 = 1, i__2 = *m * 5; - bdspac = max(i__1,i__2); -/* Computing MAX */ - i__1 = *m * 3 + *nrhs, i__2 = *m * 3 + *n, i__1 = max(i__1,i__2); - minwrk = max(i__1,bdspac); - if (*n >= mnthr) { - -/* Path 2a - underdetermined, with many more columns - than rows */ - - maxwrk = *m + *m * ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, - &c_n1, (ftnlen)6, (ftnlen)1); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) * - ilaenv_(&c__1, "DGEBRD", " ", m, m, &c_n1, &c_n1, ( - ftnlen)6, (ftnlen)1); - maxwrk = max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * ilaenv_(& - c__1, "DORMBR", "QLT", m, nrhs, m, &c_n1, (ftnlen)6, ( - ftnlen)3); - maxwrk = max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) * - ilaenv_(&c__1, "DORGBR", "P", m, m, m, &c_n1, (ftnlen) - 6, (ftnlen)1); - maxwrk = max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + *m + bdspac; - maxwrk = max(i__1,i__2); - if (*nrhs > 1) { -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs; - maxwrk = max(i__1,i__2); - } else { -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * *m + (*m << 1); - maxwrk = max(i__1,i__2); - } -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m + *nrhs * ilaenv_(&c__1, "DORMLQ", - "LT", n, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)2); - maxwrk = max(i__1,i__2); - } else { - -/* Path 2 - underdetermined */ - - maxwrk = *m * 3 + (*n + *m) * ilaenv_(&c__1, "DGEBRD", " ", m, - n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * 3 + *nrhs * ilaenv_(&c__1, "DORMBR" - , "QLT", m, nrhs, m, &c_n1, (ftnlen)6, (ftnlen)3); - maxwrk = max(i__1,i__2); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *m * 3 + *m * ilaenv_(&c__1, "DORGBR", - "P", m, n, m, &c_n1, (ftnlen)6, (ftnlen)1); - maxwrk = max(i__1,i__2); - maxwrk = max(maxwrk,bdspac); -/* Computing MAX */ - i__1 = maxwrk, i__2 = *n * *nrhs; - maxwrk = max(i__1,i__2); - } - } - maxwrk = max(minwrk,maxwrk); - work[1] = (doublereal) maxwrk; - } - - minwrk = max(minwrk,1); - if (*lwork < minwrk && ! lquery) { - *info = -12; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGELSS", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - *rank = 0; - return 0; - } - -/* Get machine parameters */ - - eps = dlamch_("P"); - sfmin = dlamch_("S"); - smlnum = sfmin / eps; - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - -/* Scale A if max element outside range [SMLNUM,BIGNUM] */ - - anrm = dlange_("M", m, n, &a[a_offset], lda, &work[1]); - iascl = 0; - if (anrm > 0. && anrm < smlnum) { - -/* Scale matrix norm up to SMLNUM */ - - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, - info); - iascl = 1; - } else if (anrm > bignum) { - -/* Scale matrix norm down to BIGNUM */ - - dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, - info); - iascl = 2; - } else if (anrm == 0.) { - -/* Matrix all zero. Return zero solution. */ - - i__1 = max(*m,*n); - dlaset_("F", &i__1, nrhs, &c_b74, &c_b74, &b[b_offset], ldb); - dlaset_("F", &minmn, &c__1, &c_b74, &c_b74, &s[1], &c__1); - *rank = 0; - goto L70; - } - -/* Scale B if max element outside range [SMLNUM,BIGNUM] */ - - bnrm = dlange_("M", m, nrhs, &b[b_offset], ldb, &work[1]); - ibscl = 0; - if (bnrm > 0. && bnrm < smlnum) { - -/* Scale matrix norm up to SMLNUM */ - - dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, - info); - ibscl = 1; - } else if (bnrm > bignum) { - -/* Scale matrix norm down to BIGNUM */ - - dlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, - info); - ibscl = 2; - } - -/* Overdetermined case */ - - if (*m >= *n) { - -/* Path 1 - overdetermined or exactly determined */ - - mm = *m; - if (*m >= mnthr) { - -/* Path 1a - overdetermined, with many more rows than columns */ - - mm = *n; - itau = 1; - iwork = itau + *n; - -/* Compute A=Q*R - (Workspace: need 2*N, prefer N+N*NB) */ - - i__1 = *lwork - iwork + 1; - dgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__1, - info); - -/* Multiply B by transpose(Q) - (Workspace: need N+NRHS, prefer N+NRHS*NB) */ - - i__1 = *lwork - iwork + 1; - dormqr_("L", "T", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[ - b_offset], ldb, &work[iwork], &i__1, info); - -/* Zero out below R */ - - if (*n > 1) { - i__1 = *n - 1; - i__2 = *n - 1; - dlaset_("L", &i__1, &i__2, &c_b74, &c_b74, &a_ref(2, 1), lda); - } - } - - ie = 1; - itauq = ie + *n; - itaup = itauq + *n; - iwork = itaup + *n; - -/* Bidiagonalize R in A - (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) */ - - i__1 = *lwork - iwork + 1; - dgebrd_(&mm, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[iwork], &i__1, info); - -/* Multiply B by transpose of left bidiagonalizing vectors of R - (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) */ - - i__1 = *lwork - iwork + 1; - dormbr_("Q", "L", "T", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], - &b[b_offset], ldb, &work[iwork], &i__1, info); - -/* Generate right bidiagonalizing vectors of R in A - (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) */ - - i__1 = *lwork - iwork + 1; - dorgbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], & - i__1, info); - iwork = ie + *n; - -/* Perform bidiagonal QR iteration - multiply B by transpose of left singular vectors - compute right singular vectors in A - (Workspace: need BDSPAC) */ - - dbdsqr_("U", n, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset], lda, - vdum, &c__1, &b[b_offset], ldb, &work[iwork], info) - ; - if (*info != 0) { - goto L70; - } - -/* Multiply B by reciprocals of singular values - - Computing MAX */ - d__1 = *rcond * s[1]; - thr = max(d__1,sfmin); - if (*rcond < 0.) { -/* Computing MAX */ - d__1 = eps * s[1]; - thr = max(d__1,sfmin); - } - *rank = 0; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (s[i__] > thr) { - drscl_(nrhs, &s[i__], &b_ref(i__, 1), ldb); - ++(*rank); - } else { - dlaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b_ref(i__, 1), ldb); - } -/* L10: */ - } - -/* Multiply B by right singular vectors - (Workspace: need N, prefer N*NRHS) */ - - if (*lwork >= *ldb * *nrhs && *nrhs > 1) { - dgemm_("T", "N", n, nrhs, n, &c_b108, &a[a_offset], lda, &b[ - b_offset], ldb, &c_b74, &work[1], ldb); - dlacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb) - ; - } else if (*nrhs > 1) { - chunk = *lwork / *n; - i__1 = *nrhs; - i__2 = chunk; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__3 = *nrhs - i__ + 1; - bl = min(i__3,chunk); - dgemm_("T", "N", n, &bl, n, &c_b108, &a[a_offset], lda, & - b_ref(1, i__), ldb, &c_b74, &work[1], n); - dlacpy_("G", n, &bl, &work[1], n, &b_ref(1, i__), ldb); -/* L20: */ - } - } else { - dgemv_("T", n, n, &c_b108, &a[a_offset], lda, &b[b_offset], &c__1, - &c_b74, &work[1], &c__1); - dcopy_(n, &work[1], &c__1, &b[b_offset], &c__1); - } - - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__2 = *m, i__1 = (*m << 1) - 4, i__2 = max(i__2,i__1), i__2 = max( - i__2,*nrhs), i__1 = *n - *m * 3; - if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + max(i__2,i__1)) { - -/* Path 2a - underdetermined, with many more columns than rows - and sufficient workspace for an efficient algorithm */ - - ldwork = *m; -/* Computing MAX - Computing MAX */ - i__3 = *m, i__4 = (*m << 1) - 4, i__3 = max(i__3,i__4), i__3 = - max(i__3,*nrhs), i__4 = *n - *m * 3; - i__2 = (*m << 2) + *m * *lda + max(i__3,i__4), i__1 = *m * *lda + - *m + *m * *nrhs; - if (*lwork >= max(i__2,i__1)) { - ldwork = *lda; - } - itau = 1; - iwork = *m + 1; - -/* Compute A=L*Q - (Workspace: need 2*M, prefer M+M*NB) */ - - i__2 = *lwork - iwork + 1; - dgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, - info); - il = iwork; - -/* Copy L to WORK(IL), zeroing out above it */ - - dlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork); - i__2 = *m - 1; - i__1 = *m - 1; - dlaset_("U", &i__2, &i__1, &c_b74, &c_b74, &work[il + ldwork], & - ldwork); - ie = il + ldwork * *m; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize L in WORK(IL) - (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) */ - - i__2 = *lwork - iwork + 1; - dgebrd_(m, m, &work[il], &ldwork, &s[1], &work[ie], &work[itauq], - &work[itaup], &work[iwork], &i__2, info); - -/* Multiply B by transpose of left bidiagonalizing vectors of L - (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */ - - i__2 = *lwork - iwork + 1; - dormbr_("Q", "L", "T", m, nrhs, m, &work[il], &ldwork, &work[ - itauq], &b[b_offset], ldb, &work[iwork], &i__2, info); - -/* Generate right bidiagonalizing vectors of R in WORK(IL) - (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB) */ - - i__2 = *lwork - iwork + 1; - dorgbr_("P", m, m, m, &work[il], &ldwork, &work[itaup], &work[ - iwork], &i__2, info); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, - computing right singular vectors of L in WORK(IL) and - multiplying B by transpose of left singular vectors - (Workspace: need M*M+M+BDSPAC) */ - - dbdsqr_("U", m, m, &c__0, nrhs, &s[1], &work[ie], &work[il], & - ldwork, &a[a_offset], lda, &b[b_offset], ldb, &work[iwork] - , info); - if (*info != 0) { - goto L70; - } - -/* Multiply B by reciprocals of singular values - - Computing MAX */ - d__1 = *rcond * s[1]; - thr = max(d__1,sfmin); - if (*rcond < 0.) { -/* Computing MAX */ - d__1 = eps * s[1]; - thr = max(d__1,sfmin); - } - *rank = 0; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - if (s[i__] > thr) { - drscl_(nrhs, &s[i__], &b_ref(i__, 1), ldb); - ++(*rank); - } else { - dlaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b_ref(i__, 1), - ldb); - } -/* L30: */ - } - iwork = ie; - -/* Multiply B by right singular vectors of L in WORK(IL) - (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS) */ - - if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) { - dgemm_("T", "N", m, nrhs, m, &c_b108, &work[il], &ldwork, &b[ - b_offset], ldb, &c_b74, &work[iwork], ldb); - dlacpy_("G", m, nrhs, &work[iwork], ldb, &b[b_offset], ldb); - } else if (*nrhs > 1) { - chunk = (*lwork - iwork + 1) / *m; - i__2 = *nrhs; - i__1 = chunk; - for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += - i__1) { -/* Computing MIN */ - i__3 = *nrhs - i__ + 1; - bl = min(i__3,chunk); - dgemm_("T", "N", m, &bl, m, &c_b108, &work[il], &ldwork, & - b_ref(1, i__), ldb, &c_b74, &work[iwork], n); - dlacpy_("G", m, &bl, &work[iwork], n, &b_ref(1, i__), ldb); -/* L40: */ - } - } else { - dgemv_("T", m, m, &c_b108, &work[il], &ldwork, &b_ref(1, 1), & - c__1, &c_b74, &work[iwork], &c__1); - dcopy_(m, &work[iwork], &c__1, &b_ref(1, 1), &c__1); - } - -/* Zero out below first M rows of B */ - - i__1 = *n - *m; - dlaset_("F", &i__1, nrhs, &c_b74, &c_b74, &b_ref(*m + 1, 1), ldb); - iwork = itau + *m; - -/* Multiply transpose(Q) by B - (Workspace: need M+NRHS, prefer M+NRHS*NB) */ - - i__1 = *lwork - iwork + 1; - dormlq_("L", "T", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[ - b_offset], ldb, &work[iwork], &i__1, info); - - } else { - -/* Path 2 - remaining underdetermined cases */ - - ie = 1; - itauq = ie + *m; - itaup = itauq + *m; - iwork = itaup + *m; - -/* Bidiagonalize A - (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) */ - - i__1 = *lwork - iwork + 1; - dgebrd_(m, n, &a[a_offset], lda, &s[1], &work[ie], &work[itauq], & - work[itaup], &work[iwork], &i__1, info); - -/* Multiply B by transpose of left bidiagonalizing vectors - (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) */ - - i__1 = *lwork - iwork + 1; - dormbr_("Q", "L", "T", m, nrhs, n, &a[a_offset], lda, &work[itauq] - , &b[b_offset], ldb, &work[iwork], &i__1, info); - -/* Generate right bidiagonalizing vectors in A - (Workspace: need 4*M, prefer 3*M+M*NB) */ - - i__1 = *lwork - iwork + 1; - dorgbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[ - iwork], &i__1, info); - iwork = ie + *m; - -/* Perform bidiagonal QR iteration, - computing right singular vectors of A in A and - multiplying B by transpose of left singular vectors - (Workspace: need BDSPAC) */ - - dbdsqr_("L", m, n, &c__0, nrhs, &s[1], &work[ie], &a[a_offset], - lda, vdum, &c__1, &b[b_offset], ldb, &work[iwork], info); - if (*info != 0) { - goto L70; - } - -/* Multiply B by reciprocals of singular values - - Computing MAX */ - d__1 = *rcond * s[1]; - thr = max(d__1,sfmin); - if (*rcond < 0.) { -/* Computing MAX */ - d__1 = eps * s[1]; - thr = max(d__1,sfmin); - } - *rank = 0; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (s[i__] > thr) { - drscl_(nrhs, &s[i__], &b_ref(i__, 1), ldb); - ++(*rank); - } else { - dlaset_("F", &c__1, nrhs, &c_b74, &c_b74, &b_ref(i__, 1), - ldb); - } -/* L50: */ - } - -/* Multiply B by right singular vectors of A - (Workspace: need N, prefer N*NRHS) */ - - if (*lwork >= *ldb * *nrhs && *nrhs > 1) { - dgemm_("T", "N", n, nrhs, m, &c_b108, &a[a_offset], lda, &b[ - b_offset], ldb, &c_b74, &work[1], ldb); - dlacpy_("F", n, nrhs, &work[1], ldb, &b[b_offset], ldb); - } else if (*nrhs > 1) { - chunk = *lwork / *n; - i__1 = *nrhs; - i__2 = chunk; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += - i__2) { -/* Computing MIN */ - i__3 = *nrhs - i__ + 1; - bl = min(i__3,chunk); - dgemm_("T", "N", n, &bl, m, &c_b108, &a[a_offset], lda, & - b_ref(1, i__), ldb, &c_b74, &work[1], n); - dlacpy_("F", n, &bl, &work[1], n, &b_ref(1, i__), ldb); -/* L60: */ - } - } else { - dgemv_("T", m, n, &c_b108, &a[a_offset], lda, &b[b_offset], & - c__1, &c_b74, &work[1], &c__1); - dcopy_(n, &work[1], &c__1, &b[b_offset], &c__1); - } - } - } - -/* Undo scaling */ - - if (iascl == 1) { - dlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, - info); - dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & - minmn, info); - } else if (iascl == 2) { - dlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, - info); - dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & - minmn, info); - } - if (ibscl == 1) { - dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, - info); - } else if (ibscl == 2) { - dlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, - info); - } - -L70: - work[1] = (doublereal) maxwrk; - return 0; - -/* End of DGELSS */ - -} /* dgelss_ */ - -#undef b_ref -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgeqr2.c b/ext/f2c_lapack/dgeqr2.c deleted file mode 100644 index 58ff5d72a..000000000 --- a/ext/f2c_lapack/dgeqr2.c +++ /dev/null @@ -1,146 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgeqr2_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - February 29, 1992 - - - Purpose - ======= - - DGEQR2 computes a QR factorization of a real m by n matrix A: - A = Q * R. - - Arguments - ========= - - M (input) INTEGER - The number of rows of the matrix A. M >= 0. - - N (input) INTEGER - The number of columns of the matrix A. N >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the m by n matrix A. - On exit, the elements on and above the diagonal of the array - contain the min(m,n) by n upper trapezoidal matrix R (R is - upper triangular if m >= n); the elements below the diagonal, - with the array TAU, represent the orthogonal matrix Q as a - product of elementary reflectors (see Further Details). - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) - The scalar factors of the elementary reflectors (see Further - Details). - - WORK (workspace) DOUBLE PRECISION array, dimension (N) - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - - Further Details - =============== - - The matrix Q is represented as a product of elementary reflectors - - Q = H(1) H(2) . . . H(k), where k = min(m,n). - - Each H(i) has the form - - H(i) = I - tau * v * v' - - where tau is a real scalar, and v is a real vector with - v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), - and tau in TAU(i). - - ===================================================================== - - - Test the input arguments - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - /* Local variables */ - static integer i__, k; - extern /* Subroutine */ int dlarf_(char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - doublereal *), dlarfg_(integer *, doublereal *, - doublereal *, integer *, doublereal *), xerbla_(char *, integer *); - static doublereal aii; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*m)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEQR2", &i__1); - return 0; - } - - k = min(*m,*n); - - i__1 = k; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) - - Computing MIN */ - i__2 = i__ + 1; - i__3 = *m - i__ + 1; - dlarfg_(&i__3, &a_ref(i__, i__), &a_ref(min(i__2,*m), i__), &c__1, & - tau[i__]); - if (i__ < *n) { - -/* Apply H(i) to A(i:m,i+1:n) from the left */ - - aii = a_ref(i__, i__); - a_ref(i__, i__) = 1.; - i__2 = *m - i__ + 1; - i__3 = *n - i__; - dlarf_("Left", &i__2, &i__3, &a_ref(i__, i__), &c__1, &tau[i__], & - a_ref(i__, i__ + 1), lda, &work[1]); - a_ref(i__, i__) = aii; - } -/* L10: */ - } - return 0; - -/* End of DGEQR2 */ - -} /* dgeqr2_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgeqrf.c b/ext/f2c_lapack/dgeqrf.c deleted file mode 100644 index 7273ff26f..000000000 --- a/ext/f2c_lapack/dgeqrf.c +++ /dev/null @@ -1,243 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgeqrf_(integer *m, integer *n, doublereal *a, integer * - lda, doublereal *tau, doublereal *work, integer *lwork, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1999 - - - Purpose - ======= - - DGEQRF computes a QR factorization of a real M-by-N matrix A: - A = Q * R. - - Arguments - ========= - - M (input) INTEGER - The number of rows of the matrix A. M >= 0. - - N (input) INTEGER - The number of columns of the matrix A. N >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the M-by-N matrix A. - On exit, the elements on and above the diagonal of the array - contain the min(M,N)-by-N upper trapezoidal matrix R (R is - upper triangular if m >= n); the elements below the diagonal, - with the array TAU, represent the orthogonal matrix Q as a - product of min(m,n) elementary reflectors (see Further - Details). - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) - The scalar factors of the elementary reflectors (see Further - Details). - - WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - - LWORK (input) INTEGER - The dimension of the array WORK. LWORK >= max(1,N). - For optimum performance LWORK >= N*NB, where NB is - the optimal blocksize. - - If LWORK = -1, then a workspace query is assumed; the routine - only calculates the optimal size of the WORK array, returns - this value as the first entry of the WORK array, and no error - message related to LWORK is issued by XERBLA. - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - - Further Details - =============== - - The matrix Q is represented as a product of elementary reflectors - - Q = H(1) H(2) . . . H(k), where k = min(m,n). - - Each H(i) has the form - - H(i) = I - tau * v * v' - - where tau is a real scalar, and v is a real vector with - v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), - and tau in TAU(i). - - ===================================================================== - - - Test the input arguments - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static integer c_n1 = -1; - static integer c__3 = 3; - static integer c__2 = 2; - - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - /* Local variables */ - static integer i__, k, nbmin, iinfo; - extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *); - static integer ib, nb; - extern /* Subroutine */ int dlarfb_(char *, char *, char *, char *, - integer *, integer *, integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *); - static integer nx; - extern /* Subroutine */ int dlarft_(char *, char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - static integer ldwork, lwkopt; - static logical lquery; - static integer iws; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen) - 1); - lwkopt = *n * nb; - work[1] = (doublereal) lwkopt; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*m)) { - *info = -4; - } else if (*lwork < max(1,*n) && ! lquery) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGEQRF", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - k = min(*m,*n); - if (k == 0) { - work[1] = 1.; - return 0; - } - - nbmin = 2; - nx = 0; - iws = *n; - if (nb > 1 && nb < k) { - -/* Determine when to cross over from blocked to unblocked code. - - Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQRF", " ", m, n, &c_n1, &c_n1, ( - ftnlen)6, (ftnlen)1); - nx = max(i__1,i__2); - if (nx < k) { - -/* Determine if workspace is large enough for blocked code. */ - - ldwork = *n; - iws = ldwork * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: reduce NB and - determine the minimum value of NB. */ - - nb = *lwork / ldwork; -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQRF", " ", m, n, &c_n1, & - c_n1, (ftnlen)6, (ftnlen)1); - nbmin = max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < k && nx < k) { - -/* Use blocked code initially */ - - i__1 = k - nx; - i__2 = nb; - for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__3 = k - i__ + 1; - ib = min(i__3,nb); - -/* Compute the QR factorization of the current block - A(i:m,i:i+ib-1) */ - - i__3 = *m - i__ + 1; - dgeqr2_(&i__3, &ib, &a_ref(i__, i__), lda, &tau[i__], &work[1], & - iinfo); - if (i__ + ib <= *n) { - -/* Form the triangular factor of the block reflector - H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__3 = *m - i__ + 1; - dlarft_("Forward", "Columnwise", &i__3, &ib, &a_ref(i__, i__), - lda, &tau[i__], &work[1], &ldwork); - -/* Apply H' to A(i:m,i+ib:n) from the left */ - - i__3 = *m - i__ + 1; - i__4 = *n - i__ - ib + 1; - dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, & - i__4, &ib, &a_ref(i__, i__), lda, &work[1], &ldwork, & - a_ref(i__, i__ + ib), lda, &work[ib + 1], &ldwork); - } -/* L10: */ - } - } else { - i__ = 1; - } - -/* Use unblocked code to factor the last or only block. */ - - if (i__ <= k) { - i__2 = *m - i__ + 1; - i__1 = *n - i__ + 1; - dgeqr2_(&i__2, &i__1, &a_ref(i__, i__), lda, &tau[i__], &work[1], & - iinfo); - } - - work[1] = (doublereal) iws; - return 0; - -/* End of DGEQRF */ - -} /* dgeqrf_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgerfs.c b/ext/f2c_lapack/dgerfs.c deleted file mode 100644 index 5dcebe627..000000000 --- a/ext/f2c_lapack/dgerfs.c +++ /dev/null @@ -1,420 +0,0 @@ -/* dgerfs.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static doublereal c_b15 = -1.; -static doublereal c_b17 = 1.; - -/* Subroutine */ int dgerfs_(char *trans, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *af, integer *ldaf, integer * - ipiv, doublereal *b, integer *ldb, doublereal *x, integer *ldx, - doublereal *ferr, doublereal *berr, doublereal *work, integer *iwork, - integer *info, ftnlen trans_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, - x_offset, i__1, i__2, i__3; - doublereal d__1, d__2, d__3; - - /* Local variables */ - static integer i__, j, k; - static doublereal s, xk; - static integer nz; - static doublereal eps; - static integer kase; - static doublereal safe1, safe2; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, ftnlen), dcopy_(integer *, - doublereal *, integer *, doublereal *, integer *), daxpy_(integer - *, doublereal *, doublereal *, integer *, doublereal *, integer *) - ; - static integer count; - extern doublereal dlamch_(char *, ftnlen); - extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - static doublereal safmin; - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dgetrs_( - char *, integer *, integer *, doublereal *, integer *, integer *, - doublereal *, integer *, integer *, ftnlen); - static logical notran; - static char transt[1]; - static doublereal lstres; - - -/* -- LAPACK routine (version 3.0) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ -/* Courant Institute, Argonne National Lab, and Rice University */ -/* September 30, 1994 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DGERFS improves the computed solution to a system of linear */ -/* equations and provides error bounds and backward error estimates for */ -/* the solution. */ - -/* Arguments */ -/* ========= */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrices B and X. NRHS >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The original N-by-N matrix A. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) */ -/* The factors L and U from the factorization A = P*L*U */ -/* as computed by DGETRF. */ - -/* LDAF (input) INTEGER */ -/* The leading dimension of the array AF. LDAF >= max(1,N). */ - -/* IPIV (input) INTEGER array, dimension (N) */ -/* The pivot indices from DGETRF; for 1<=i<=N, row i of the */ -/* matrix was interchanged with row IPIV(i). */ - -/* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* The right hand side matrix B. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) */ -/* On entry, the solution matrix X, as computed by DGETRS. */ -/* On exit, the improved solution matrix X. */ - -/* LDX (input) INTEGER */ -/* The leading dimension of the array X. LDX >= max(1,N). */ - -/* FERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The estimated forward error bound for each solution vector */ -/* X(j) (the j-th column of the solution matrix X). */ -/* If XTRUE is the true solution corresponding to X(j), FERR(j) */ -/* is an estimated upper bound for the magnitude of the largest */ -/* element in (X(j) - XTRUE) divided by the magnitude of the */ -/* largest element in X(j). The estimate is as reliable as */ -/* the estimate for RCOND, and is almost always a slight */ -/* overestimate of the true error. */ - -/* BERR (output) DOUBLE PRECISION array, dimension (NRHS) */ -/* The componentwise relative backward error of each solution */ -/* vector X(j) (i.e., the smallest relative change in */ -/* any element of A or B that makes X(j) an exact solution). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* Internal Parameters */ -/* =================== */ - -/* ITMAX is the maximum number of steps of iterative refinement. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - af_dim1 = *ldaf; - af_offset = 1 + af_dim1; - af -= af_offset; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - x_dim1 = *ldx; - x_offset = 1 + x_dim1; - x -= x_offset; - --ferr; - --berr; - --work; - --iwork; - - /* Function Body */ - *info = 0; - notran = lsame_(trans, "N", (ftnlen)1, (ftnlen)1); - if (! notran && ! lsame_(trans, "T", (ftnlen)1, (ftnlen)1) && ! lsame_( - trans, "C", (ftnlen)1, (ftnlen)1)) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < max(1,*n)) { - *info = -5; - } else if (*ldaf < max(1,*n)) { - *info = -7; - } else if (*ldb < max(1,*n)) { - *info = -10; - } else if (*ldx < max(1,*n)) { - *info = -12; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGERFS", &i__1, (ftnlen)6); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - ferr[j] = 0.; - berr[j] = 0.; -/* L10: */ - } - return 0; - } - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - -/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ - - nz = *n + 1; - eps = dlamch_("Epsilon", (ftnlen)7); - safmin = dlamch_("Safe minimum", (ftnlen)12); - safe1 = nz * safmin; - safe2 = safe1 / eps; - -/* Do for each right hand side */ - - i__1 = *nrhs; - for (j = 1; j <= i__1; ++j) { - - count = 1; - lstres = 3.; -L20: - -/* Loop until stopping criterion is satisfied. */ - -/* Compute residual R = B - op(A) * X, */ -/* where op(A) = A, A**T, or A**H, depending on TRANS. */ - - dcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); - dgemv_(trans, n, n, &c_b15, &a[a_offset], lda, &x[j * x_dim1 + 1], & - c__1, &c_b17, &work[*n + 1], &c__1, (ftnlen)1); - -/* Compute componentwise relative backward error from formula */ - -/* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ - -/* where abs(Z) is the componentwise absolute value of the matrix */ -/* or vector Z. If the i-th component of the denominator is less */ -/* than SAFE2, then SAFE1 is added to the i-th components of the */ -/* numerator and denominator before dividing. */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); -/* L30: */ - } - -/* Compute abs(op(A))*abs(X) + abs(B). */ - - if (notran) { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - xk = (d__1 = x[k + j * x_dim1], abs(d__1)); - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - work[i__] += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * xk; -/* L40: */ - } -/* L50: */ - } - } else { - i__2 = *n; - for (k = 1; k <= i__2; ++k) { - s = 0.; - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * (d__2 = x[ - i__ + j * x_dim1], abs(d__2)); -/* L60: */ - } - work[k] += s; -/* L70: */ - } - } - s = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { -/* Computing MAX */ - d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ - i__]; - s = max(d__2,d__3); - } else { -/* Computing MAX */ - d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) - / (work[i__] + safe1); - s = max(d__2,d__3); - } -/* L80: */ - } - berr[j] = s; - -/* Test stopping criterion. Continue iterating if */ -/* 1) The residual BERR(J) is larger than machine epsilon, and */ -/* 2) BERR(J) decreased by at least a factor of 2 during the */ -/* last iteration, and */ -/* 3) At most ITMAX iterations tried. */ - - if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { - -/* Update solution and try again. */ - - dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n - + 1], n, info, (ftnlen)1); - daxpy_(n, &c_b17, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) - ; - lstres = berr[j]; - ++count; - goto L20; - } - -/* Bound error from formula */ - -/* norm(X - XTRUE) / norm(X) .le. FERR = */ -/* norm( abs(inv(op(A)))* */ -/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ - -/* where */ -/* norm(Z) is the magnitude of the largest component of Z */ -/* inv(op(A)) is the inverse of op(A) */ -/* abs(Z) is the componentwise absolute value of the matrix or */ -/* vector Z */ -/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ -/* EPS is machine epsilon */ - -/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ -/* is incremented by SAFE1 if the i-th component of */ -/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ - -/* Use DLACON to estimate the infinity-norm of the matrix */ -/* inv(op(A)) * diag(W), */ -/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - if (work[i__] > safe2) { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__]; - } else { - work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * - work[i__] + safe1; - } -/* L90: */ - } - - kase = 0; -L100: - dlacon_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & - kase); - if (kase != 0) { - if (kase == 1) { - -/* Multiply by diag(W)*inv(op(A)**T). */ - - dgetrs_(transt, n, &c__1, &af[af_offset], ldaf, &ipiv[1], & - work[*n + 1], n, info, (ftnlen)1); - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L110: */ - } - } else { - -/* Multiply by inv(op(A))*diag(W). */ - - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - work[*n + i__] = work[i__] * work[*n + i__]; -/* L120: */ - } - dgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], & - work[*n + 1], n, info, (ftnlen)1); - } - goto L100; - } - -/* Normalize error. */ - - lstres = 0.; - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); - lstres = max(d__2,d__3); -/* L130: */ - } - if (lstres != 0.) { - ferr[j] /= lstres; - } - -/* L140: */ - } - - return 0; - -/* End of DGERFS */ - -} /* dgerfs_ */ - diff --git a/ext/f2c_lapack/dgetf2.c b/ext/f2c_lapack/dgetf2.c deleted file mode 100644 index 9aaf1bcfe..000000000 --- a/ext/f2c_lapack/dgetf2.c +++ /dev/null @@ -1,163 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgetf2_(integer *m, integer *n, doublereal *a, integer * - lda, integer *ipiv, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1992 - - - Purpose - ======= - - DGETF2 computes an LU factorization of a general m-by-n matrix A - using partial pivoting with row interchanges. - - The factorization has the form - A = P * L * U - where P is a permutation matrix, L is lower triangular with unit - diagonal elements (lower trapezoidal if m > n), and U is upper - triangular (upper trapezoidal if m < n). - - This is the right-looking Level 2 BLAS version of the algorithm. - - Arguments - ========= - - M (input) INTEGER - The number of rows of the matrix A. M >= 0. - - N (input) INTEGER - The number of columns of the matrix A. N >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the m by n matrix to be factored. - On exit, the factors L and U from the factorization - A = P*L*U; the unit diagonal elements of L are not stored. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - IPIV (output) INTEGER array, dimension (min(M,N)) - The pivot indices; for 1 <= i <= min(M,N), row i of the - matrix was interchanged with row IPIV(i). - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -k, the k-th argument had an illegal value - > 0: if INFO = k, U(k,k) is exactly zero. The factorization - has been completed, but the factor U is exactly - singular, and division by zero will occur if it is used - to solve a system of equations. - - ===================================================================== - - - Test the input parameters. - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static doublereal c_b6 = -1.; - - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - doublereal d__1; - /* Local variables */ - extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *); - static integer j; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dswap_(integer *, doublereal *, integer *, doublereal - *, integer *); - static integer jp; - extern integer idamax_(integer *, doublereal *, integer *); - extern /* Subroutine */ int xerbla_(char *, integer *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --ipiv; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*m)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGETF2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - - i__1 = min(*m,*n); - for (j = 1; j <= i__1; ++j) { - -/* Find pivot and test for singularity. */ - - i__2 = *m - j + 1; - jp = j - 1 + idamax_(&i__2, &a_ref(j, j), &c__1); - ipiv[j] = jp; - if (a_ref(jp, j) != 0.) { - -/* Apply the interchange to columns 1:N. */ - - if (jp != j) { - dswap_(n, &a_ref(j, 1), lda, &a_ref(jp, 1), lda); - } - -/* Compute elements J+1:M of J-th column. */ - - if (j < *m) { - i__2 = *m - j; - d__1 = 1. / a_ref(j, j); - dscal_(&i__2, &d__1, &a_ref(j + 1, j), &c__1); - } - - } else if (*info == 0) { - - *info = j; - } - - if (j < min(*m,*n)) { - -/* Update trailing submatrix. */ - - i__2 = *m - j; - i__3 = *n - j; - dger_(&i__2, &i__3, &c_b6, &a_ref(j + 1, j), &c__1, &a_ref(j, j + - 1), lda, &a_ref(j + 1, j + 1), lda); - } -/* L10: */ - } - return 0; - -/* End of DGETF2 */ - -} /* dgetf2_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgetrf.c b/ext/f2c_lapack/dgetrf.c deleted file mode 100644 index b0cb3cb08..000000000 --- a/ext/f2c_lapack/dgetrf.c +++ /dev/null @@ -1,203 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgetrf_(integer *m, integer *n, doublereal *a, integer * - lda, integer *ipiv, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - March 31, 1993 - - - Purpose - ======= - - DGETRF computes an LU factorization of a general M-by-N matrix A - using partial pivoting with row interchanges. - - The factorization has the form - A = P * L * U - where P is a permutation matrix, L is lower triangular with unit - diagonal elements (lower trapezoidal if m > n), and U is upper - triangular (upper trapezoidal if m < n). - - This is the right-looking Level 3 BLAS version of the algorithm. - - Arguments - ========= - - M (input) INTEGER - The number of rows of the matrix A. M >= 0. - - N (input) INTEGER - The number of columns of the matrix A. N >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the M-by-N matrix to be factored. - On exit, the factors L and U from the factorization - A = P*L*U; the unit diagonal elements of L are not stored. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - IPIV (output) INTEGER array, dimension (min(M,N)) - The pivot indices; for 1 <= i <= min(M,N), row i of the - matrix was interchanged with row IPIV(i). - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - > 0: if INFO = i, U(i,i) is exactly zero. The factorization - has been completed, but the factor U is exactly - singular, and division by zero will occur if it is used - to solve a system of equations. - - ===================================================================== - - - Test the input parameters. - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static integer c_n1 = -1; - static doublereal c_b16 = 1.; - static doublereal c_b19 = -1.; - - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; - /* Local variables */ - static integer i__, j; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *); - static integer iinfo; - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *), dgetf2_( - integer *, integer *, doublereal *, integer *, integer *, integer - *); - static integer jb, nb; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int dlaswp_(integer *, doublereal *, integer *, - integer *, integer *, integer *, integer *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --ipiv; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*m)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGETRF", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - -/* Determine the block size for this environment. */ - - nb = ilaenv_(&c__1, "DGETRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen) - 1); - if (nb <= 1 || nb >= min(*m,*n)) { - -/* Use unblocked code. */ - - dgetf2_(m, n, &a[a_offset], lda, &ipiv[1], info); - } else { - -/* Use blocked code. */ - - i__1 = min(*m,*n); - i__2 = nb; - for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { -/* Computing MIN */ - i__3 = min(*m,*n) - j + 1; - jb = min(i__3,nb); - -/* Factor diagonal and subdiagonal blocks and test for exact - singularity. */ - - i__3 = *m - j + 1; - dgetf2_(&i__3, &jb, &a_ref(j, j), lda, &ipiv[j], &iinfo); - -/* Adjust INFO and the pivot indices. */ - - if (*info == 0 && iinfo > 0) { - *info = iinfo + j - 1; - } -/* Computing MIN */ - i__4 = *m, i__5 = j + jb - 1; - i__3 = min(i__4,i__5); - for (i__ = j; i__ <= i__3; ++i__) { - ipiv[i__] = j - 1 + ipiv[i__]; -/* L10: */ - } - -/* Apply interchanges to columns 1:J-1. */ - - i__3 = j - 1; - i__4 = j + jb - 1; - dlaswp_(&i__3, &a[a_offset], lda, &j, &i__4, &ipiv[1], &c__1); - - if (j + jb <= *n) { - -/* Apply interchanges to columns J+JB:N. */ - - i__3 = *n - j - jb + 1; - i__4 = j + jb - 1; - dlaswp_(&i__3, &a_ref(1, j + jb), lda, &j, &i__4, &ipiv[1], & - c__1); - -/* Compute block row of U. */ - - i__3 = *n - j - jb + 1; - dtrsm_("Left", "Lower", "No transpose", "Unit", &jb, &i__3, & - c_b16, &a_ref(j, j), lda, &a_ref(j, j + jb), lda); - if (j + jb <= *m) { - -/* Update trailing submatrix. */ - - i__3 = *m - j - jb + 1; - i__4 = *n - j - jb + 1; - dgemm_("No transpose", "No transpose", &i__3, &i__4, &jb, - &c_b19, &a_ref(j + jb, j), lda, &a_ref(j, j + jb), - lda, &c_b16, &a_ref(j + jb, j + jb), lda); - } - } -/* L20: */ - } - } - return 0; - -/* End of DGETRF */ - -} /* dgetrf_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgetri.c b/ext/f2c_lapack/dgetri.c deleted file mode 100644 index a0431d84c..000000000 --- a/ext/f2c_lapack/dgetri.c +++ /dev/null @@ -1,249 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgetri_(integer *n, doublereal *a, integer *lda, integer - *ipiv, doublereal *work, integer *lwork, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1999 - - - Purpose - ======= - - DGETRI computes the inverse of a matrix using the LU factorization - computed by DGETRF. - - This method inverts U and then computes inv(A) by solving the system - inv(A)*L = inv(U) for inv(A). - - Arguments - ========= - - N (input) INTEGER - The order of the matrix A. N >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the factors L and U from the factorization - A = P*L*U as computed by DGETRF. - On exit, if INFO = 0, the inverse of the original matrix A. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,N). - - IPIV (input) INTEGER array, dimension (N) - The pivot indices from DGETRF; for 1<=i<=N, row i of the - matrix was interchanged with row IPIV(i). - - WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) - On exit, if INFO=0, then WORK(1) returns the optimal LWORK. - - LWORK (input) INTEGER - The dimension of the array WORK. LWORK >= max(1,N). - For optimal performance LWORK >= N*NB, where NB is - the optimal blocksize returned by ILAENV. - - If LWORK = -1, then a workspace query is assumed; the routine - only calculates the optimal size of the WORK array, returns - this value as the first entry of the WORK array, and no error - message related to LWORK is issued by XERBLA. - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - > 0: if INFO = i, U(i,i) is exactly zero; the matrix is - singular and its inverse could not be computed. - - ===================================================================== - - - Test the input parameters. - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static integer c_n1 = -1; - static integer c__2 = 2; - static doublereal c_b20 = -1.; - static doublereal c_b22 = 1.; - - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - /* Local variables */ - static integer i__, j; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *), - dgemv_(char *, integer *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *); - static integer nbmin; - extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, - doublereal *, integer *), dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *); - static integer jb, nb, jj, jp, nn; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - static integer ldwork; - extern /* Subroutine */ int dtrtri_(char *, char *, integer *, doublereal - *, integer *, integer *); - static integer lwkopt; - static logical lquery; - static integer iws; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --ipiv; - --work; - - /* Function Body */ - *info = 0; - nb = ilaenv_(&c__1, "DGETRI", " ", n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( - ftnlen)1); - lwkopt = *n * nb; - work[1] = (doublereal) lwkopt; - lquery = *lwork == -1; - if (*n < 0) { - *info = -1; - } else if (*lda < max(1,*n)) { - *info = -3; - } else if (*lwork < max(1,*n) && ! lquery) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGETRI", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, - and the inverse is not computed. */ - - dtrtri_("Upper", "Non-unit", n, &a[a_offset], lda, info); - if (*info > 0) { - return 0; - } - - nbmin = 2; - ldwork = *n; - if (nb > 1 && nb < *n) { -/* Computing MAX */ - i__1 = ldwork * nb; - iws = max(i__1,1); - if (*lwork < iws) { - nb = *lwork / ldwork; -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DGETRI", " ", n, &c_n1, &c_n1, & - c_n1, (ftnlen)6, (ftnlen)1); - nbmin = max(i__1,i__2); - } - } else { - iws = *n; - } - -/* Solve the equation inv(A)*L = inv(U) for inv(A). */ - - if (nb < nbmin || nb >= *n) { - -/* Use unblocked code. */ - - for (j = *n; j >= 1; --j) { - -/* Copy current column of L to WORK and replace with zeros. */ - - i__1 = *n; - for (i__ = j + 1; i__ <= i__1; ++i__) { - work[i__] = a_ref(i__, j); - a_ref(i__, j) = 0.; -/* L10: */ - } - -/* Compute current column of inv(A). */ - - if (j < *n) { - i__1 = *n - j; - dgemv_("No transpose", n, &i__1, &c_b20, &a_ref(1, j + 1), - lda, &work[j + 1], &c__1, &c_b22, &a_ref(1, j), &c__1); - } -/* L20: */ - } - } else { - -/* Use blocked code. */ - - nn = (*n - 1) / nb * nb + 1; - i__1 = -nb; - for (j = nn; i__1 < 0 ? j >= 1 : j <= 1; j += i__1) { -/* Computing MIN */ - i__2 = nb, i__3 = *n - j + 1; - jb = min(i__2,i__3); - -/* Copy current block column of L to WORK and replace with - zeros. */ - - i__2 = j + jb - 1; - for (jj = j; jj <= i__2; ++jj) { - i__3 = *n; - for (i__ = jj + 1; i__ <= i__3; ++i__) { - work[i__ + (jj - j) * ldwork] = a_ref(i__, jj); - a_ref(i__, jj) = 0.; -/* L30: */ - } -/* L40: */ - } - -/* Compute current block column of inv(A). */ - - if (j + jb <= *n) { - i__2 = *n - j - jb + 1; - dgemm_("No transpose", "No transpose", n, &jb, &i__2, &c_b20, - &a_ref(1, j + jb), lda, &work[j + jb], &ldwork, & - c_b22, &a_ref(1, j), lda); - } - dtrsm_("Right", "Lower", "No transpose", "Unit", n, &jb, &c_b22, & - work[j], &ldwork, &a_ref(1, j), lda); -/* L50: */ - } - } - -/* Apply column interchanges. */ - - for (j = *n - 1; j >= 1; --j) { - jp = ipiv[j]; - if (jp != j) { - dswap_(n, &a_ref(1, j), &c__1, &a_ref(1, jp), &c__1); - } -/* L60: */ - } - - work[1] = (doublereal) iws; - return 0; - -/* End of DGETRI */ - -} /* dgetri_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dgetrs.c b/ext/f2c_lapack/dgetrs.c deleted file mode 100644 index 8b6c3198c..000000000 --- a/ext/f2c_lapack/dgetrs.c +++ /dev/null @@ -1,165 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dgetrs_(char *trans, integer *n, integer *nrhs, - doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer * - ldb, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - March 31, 1993 - - - Purpose - ======= - - DGETRS solves a system of linear equations - A * X = B or A' * X = B - with a general N-by-N matrix A using the LU factorization computed - by DGETRF. - - Arguments - ========= - - TRANS (input) CHARACTER*1 - Specifies the form of the system of equations: - = 'N': A * X = B (No transpose) - = 'T': A'* X = B (Transpose) - = 'C': A'* X = B (Conjugate transpose = Transpose) - - N (input) INTEGER - The order of the matrix A. N >= 0. - - NRHS (input) INTEGER - The number of right hand sides, i.e., the number of columns - of the matrix B. NRHS >= 0. - - A (input) DOUBLE PRECISION array, dimension (LDA,N) - The factors L and U from the factorization A = P*L*U - as computed by DGETRF. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,N). - - IPIV (input) INTEGER array, dimension (N) - The pivot indices from DGETRF; for 1<=i<=N, row i of the - matrix was interchanged with row IPIV(i). - - B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) - On entry, the right hand side matrix B. - On exit, the solution matrix X. - - LDB (input) INTEGER - The leading dimension of the array B. LDB >= max(1,N). - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - - ===================================================================== - - - Test the input parameters. - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static doublereal c_b12 = 1.; - static integer c_n1 = -1; - - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1; - /* Local variables */ - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *), xerbla_( - char *, integer *), dlaswp_(integer *, doublereal *, - integer *, integer *, integer *, integer *, integer *); - static logical notran; - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --ipiv; - b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - - /* Function Body */ - *info = 0; - notran = lsame_(trans, "N"); - if (! notran && ! lsame_(trans, "T") && ! lsame_( - trans, "C")) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < max(1,*n)) { - *info = -5; - } else if (*ldb < max(1,*n)) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DGETRS", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - - if (notran) { - -/* Solve A * X = B. - - Apply row interchanges to the right hand sides. */ - - dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c__1); - -/* Solve L*X = B, overwriting B with X. */ - - dtrsm_("Left", "Lower", "No transpose", "Unit", n, nrhs, &c_b12, &a[ - a_offset], lda, &b[b_offset], ldb); - -/* Solve U*X = B, overwriting B with X. */ - - dtrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b12, & - a[a_offset], lda, &b[b_offset], ldb); - } else { - -/* Solve A' * X = B. - - Solve U'*X = B, overwriting B with X. */ - - dtrsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b12, &a[ - a_offset], lda, &b[b_offset], ldb); - -/* Solve L'*X = B, overwriting B with X. */ - - dtrsm_("Left", "Lower", "Transpose", "Unit", n, nrhs, &c_b12, &a[ - a_offset], lda, &b[b_offset], ldb); - -/* Apply row interchanges to the solution vectors. */ - - dlaswp_(nrhs, &b[b_offset], ldb, &c__1, n, &ipiv[1], &c_n1); - } - - return 0; - -/* End of DGETRS */ - -} /* dgetrs_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlabad.c b/ext/f2c_lapack/dlabad.c deleted file mode 100644 index a58c13541..000000000 --- a/ext/f2c_lapack/dlabad.c +++ /dev/null @@ -1,62 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlabad_(doublereal *small, doublereal *large) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1992 - - - Purpose - ======= - - DLABAD takes as input the values computed by DLAMCH for underflow and - overflow, and returns the square root of each of these values if the - log of LARGE is sufficiently large. This subroutine is intended to - identify machines with a large exponent range, such as the Crays, and - redefine the underflow and overflow limits to be the square roots of - the values computed by DLAMCH. This subroutine is needed because - DLAMCH does not compensate for poor arithmetic in the upper half of - the exponent range, as is found on a Cray. - - Arguments - ========= - - SMALL (input/output) DOUBLE PRECISION - On entry, the underflow threshold as computed by DLAMCH. - On exit, if LOG10(LARGE) is sufficiently large, the square - root of SMALL, otherwise unchanged. - - LARGE (input/output) DOUBLE PRECISION - On entry, the overflow threshold as computed by DLAMCH. - On exit, if LOG10(LARGE) is sufficiently large, the square - root of LARGE, otherwise unchanged. - - ===================================================================== - - - If it looks like we're on a Cray, take the square root of - SMALL and LARGE to avoid overflow and underflow problems. */ - /* Builtin functions */ - double d_lg10(doublereal *), sqrt(doublereal); - - - if (d_lg10(large) > 2e3) { - *small = sqrt(*small); - *large = sqrt(*large); - } - - return 0; - -/* End of DLABAD */ - -} /* dlabad_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlabrd.c b/ext/f2c_lapack/dlabrd.c deleted file mode 100644 index 8007e6c9c..000000000 --- a/ext/f2c_lapack/dlabrd.c +++ /dev/null @@ -1,418 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlabrd_(integer *m, integer *n, integer *nb, doublereal * - a, integer *lda, doublereal *d__, doublereal *e, doublereal *tauq, - doublereal *taup, doublereal *x, integer *ldx, doublereal *y, integer - *ldy) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - February 29, 1992 - - - Purpose - ======= - - DLABRD reduces the first NB rows and columns of a real general - m by n matrix A to upper or lower bidiagonal form by an orthogonal - transformation Q' * A * P, and returns the matrices X and Y which - are needed to apply the transformation to the unreduced part of A. - - If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower - bidiagonal form. - - This is an auxiliary routine called by DGEBRD - - Arguments - ========= - - M (input) INTEGER - The number of rows in the matrix A. - - N (input) INTEGER - The number of columns in the matrix A. - - NB (input) INTEGER - The number of leading rows and columns of A to be reduced. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the m by n general matrix to be reduced. - On exit, the first NB rows and columns of the matrix are - overwritten; the rest of the array is unchanged. - If m >= n, elements on and below the diagonal in the first NB - columns, with the array TAUQ, represent the orthogonal - matrix Q as a product of elementary reflectors; and - elements above the diagonal in the first NB rows, with the - array TAUP, represent the orthogonal matrix P as a product - of elementary reflectors. - If m < n, elements below the diagonal in the first NB - columns, with the array TAUQ, represent the orthogonal - matrix Q as a product of elementary reflectors, and - elements on and above the diagonal in the first NB rows, - with the array TAUP, represent the orthogonal matrix P as - a product of elementary reflectors. - See Further Details. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - D (output) DOUBLE PRECISION array, dimension (NB) - The diagonal elements of the first NB rows and columns of - the reduced matrix. D(i) = A(i,i). - - E (output) DOUBLE PRECISION array, dimension (NB) - The off-diagonal elements of the first NB rows and columns of - the reduced matrix. - - TAUQ (output) DOUBLE PRECISION array dimension (NB) - The scalar factors of the elementary reflectors which - represent the orthogonal matrix Q. See Further Details. - - TAUP (output) DOUBLE PRECISION array, dimension (NB) - The scalar factors of the elementary reflectors which - represent the orthogonal matrix P. See Further Details. - - X (output) DOUBLE PRECISION array, dimension (LDX,NB) - The m-by-nb matrix X required to update the unreduced part - of A. - - LDX (input) INTEGER - The leading dimension of the array X. LDX >= M. - - Y (output) DOUBLE PRECISION array, dimension (LDY,NB) - The n-by-nb matrix Y required to update the unreduced part - of A. - - LDY (output) INTEGER - The leading dimension of the array Y. LDY >= N. - - Further Details - =============== - - The matrices Q and P are represented as products of elementary - reflectors: - - Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) - - Each H(i) and G(i) has the form: - - H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' - - where tauq and taup are real scalars, and v and u are real vectors. - - If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in - A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in - A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). - - If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in - A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in - A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). - - The elements of the vectors v and u together form the m-by-nb matrix - V and the nb-by-n matrix U' which are needed, with X and Y, to apply - the transformation to the unreduced part of the matrix, using a block - update of the form: A := A - V*Y' - X*U'. - - The contents of A on exit are illustrated by the following examples - with nb = 2: - - m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): - - ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) - ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) - ( v1 v2 a a a ) ( v1 1 a a a a ) - ( v1 v2 a a a ) ( v1 v2 a a a a ) - ( v1 v2 a a a ) ( v1 v2 a a a a ) - ( v1 v2 a a a ) - - where a denotes an element of the original matrix which is unchanged, - vi denotes an element of the vector defining H(i), and ui an element - of the vector defining G(i). - - ===================================================================== - - - Quick return if possible - - Parameter adjustments */ - /* Table of constant values */ - static doublereal c_b4 = -1.; - static doublereal c_b5 = 1.; - static integer c__1 = 1; - static doublereal c_b16 = 0.; - - /* System generated locals */ - integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2, - i__3; - /* Local variables */ - static integer i__; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dgemv_(char *, integer *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - doublereal *, integer *), dlarfg_(integer *, doublereal *, - doublereal *, integer *, doublereal *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -#define x_ref(a_1,a_2) x[(a_2)*x_dim1 + a_1] -#define y_ref(a_1,a_2) y[(a_2)*y_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --d__; - --e; - --tauq; - --taup; - x_dim1 = *ldx; - x_offset = 1 + x_dim1 * 1; - x -= x_offset; - y_dim1 = *ldy; - y_offset = 1 + y_dim1 * 1; - y -= y_offset; - - /* Function Body */ - if (*m <= 0 || *n <= 0) { - return 0; - } - - if (*m >= *n) { - -/* Reduce to upper bidiagonal form */ - - i__1 = *nb; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Update A(i:m,i) */ - - i__2 = *m - i__ + 1; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &a_ref(i__, 1), lda, & - y_ref(i__, 1), ldy, &c_b5, &a_ref(i__, i__), &c__1); - i__2 = *m - i__ + 1; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &x_ref(i__, 1), ldx, & - a_ref(1, i__), &c__1, &c_b5, &a_ref(i__, i__), &c__1); - -/* Generate reflection Q(i) to annihilate A(i+1:m,i) - - Computing MIN */ - i__2 = i__ + 1; - i__3 = *m - i__ + 1; - dlarfg_(&i__3, &a_ref(i__, i__), &a_ref(min(i__2,*m), i__), &c__1, - &tauq[i__]); - d__[i__] = a_ref(i__, i__); - if (i__ < *n) { - a_ref(i__, i__) = 1.; - -/* Compute Y(i+1:n,i) */ - - i__2 = *m - i__ + 1; - i__3 = *n - i__; - dgemv_("Transpose", &i__2, &i__3, &c_b5, &a_ref(i__, i__ + 1), - lda, &a_ref(i__, i__), &c__1, &c_b16, &y_ref(i__ + 1, - i__), &c__1); - i__2 = *m - i__ + 1; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b5, &a_ref(i__, 1), lda, - &a_ref(i__, i__), &c__1, &c_b16, &y_ref(1, i__), & - c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &y_ref(i__ + 1, 1) - , ldy, &y_ref(1, i__), &c__1, &c_b5, &y_ref(i__ + 1, - i__), &c__1); - i__2 = *m - i__ + 1; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b5, &x_ref(i__, 1), ldx, - &a_ref(i__, i__), &c__1, &c_b16, &y_ref(1, i__), & - c__1); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_("Transpose", &i__2, &i__3, &c_b4, &a_ref(1, i__ + 1), - lda, &y_ref(1, i__), &c__1, &c_b5, &y_ref(i__ + 1, - i__), &c__1); - i__2 = *n - i__; - dscal_(&i__2, &tauq[i__], &y_ref(i__ + 1, i__), &c__1); - -/* Update A(i,i+1:n) */ - - i__2 = *n - i__; - dgemv_("No transpose", &i__2, &i__, &c_b4, &y_ref(i__ + 1, 1), - ldy, &a_ref(i__, 1), lda, &c_b5, &a_ref(i__, i__ + 1) - , lda); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_("Transpose", &i__2, &i__3, &c_b4, &a_ref(1, i__ + 1), - lda, &x_ref(i__, 1), ldx, &c_b5, &a_ref(i__, i__ + 1), - lda); - -/* Generate reflection P(i) to annihilate A(i,i+2:n) - - Computing MIN */ - i__2 = i__ + 2; - i__3 = *n - i__; - dlarfg_(&i__3, &a_ref(i__, i__ + 1), &a_ref(i__, min(i__2,*n)) - , lda, &taup[i__]); - e[i__] = a_ref(i__, i__ + 1); - a_ref(i__, i__ + 1) = 1.; - -/* Compute X(i+1:m,i) */ - - i__2 = *m - i__; - i__3 = *n - i__; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1, - i__ + 1), lda, &a_ref(i__, i__ + 1), lda, &c_b16, & - x_ref(i__ + 1, i__), &c__1); - i__2 = *n - i__; - dgemv_("Transpose", &i__2, &i__, &c_b5, &y_ref(i__ + 1, 1), - ldy, &a_ref(i__, i__ + 1), lda, &c_b16, &x_ref(1, i__) - , &c__1); - i__2 = *m - i__; - dgemv_("No transpose", &i__2, &i__, &c_b4, &a_ref(i__ + 1, 1), - lda, &x_ref(1, i__), &c__1, &c_b5, &x_ref(i__ + 1, - i__), &c__1); - i__2 = i__ - 1; - i__3 = *n - i__; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(1, i__ + 1) - , lda, &a_ref(i__, i__ + 1), lda, &c_b16, &x_ref(1, - i__), &c__1); - i__2 = *m - i__; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &x_ref(i__ + 1, 1) - , ldx, &x_ref(1, i__), &c__1, &c_b5, &x_ref(i__ + 1, - i__), &c__1); - i__2 = *m - i__; - dscal_(&i__2, &taup[i__], &x_ref(i__ + 1, i__), &c__1); - } -/* L10: */ - } - } else { - -/* Reduce to lower bidiagonal form */ - - i__1 = *nb; - for (i__ = 1; i__ <= i__1; ++i__) { - -/* Update A(i,i:n) */ - - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &y_ref(i__, 1), ldy, & - a_ref(i__, 1), lda, &c_b5, &a_ref(i__, i__), lda); - i__2 = i__ - 1; - i__3 = *n - i__ + 1; - dgemv_("Transpose", &i__2, &i__3, &c_b4, &a_ref(1, i__), lda, & - x_ref(i__, 1), ldx, &c_b5, &a_ref(i__, i__), lda); - -/* Generate reflection P(i) to annihilate A(i,i+1:n) - - Computing MIN */ - i__2 = i__ + 1; - i__3 = *n - i__ + 1; - dlarfg_(&i__3, &a_ref(i__, i__), &a_ref(i__, min(i__2,*n)), lda, & - taup[i__]); - d__[i__] = a_ref(i__, i__); - if (i__ < *m) { - a_ref(i__, i__) = 1.; - -/* Compute X(i+1:m,i) */ - - i__2 = *m - i__; - i__3 = *n - i__ + 1; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1, - i__), lda, &a_ref(i__, i__), lda, &c_b16, &x_ref(i__ - + 1, i__), &c__1); - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b5, &y_ref(i__, 1), ldy, - &a_ref(i__, i__), lda, &c_b16, &x_ref(1, i__), &c__1); - i__2 = *m - i__; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &a_ref(i__ + 1, 1) - , lda, &x_ref(1, i__), &c__1, &c_b5, &x_ref(i__ + 1, - i__), &c__1); - i__2 = i__ - 1; - i__3 = *n - i__ + 1; - dgemv_("No transpose", &i__2, &i__3, &c_b5, &a_ref(1, i__), - lda, &a_ref(i__, i__), lda, &c_b16, &x_ref(1, i__), & - c__1); - i__2 = *m - i__; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &x_ref(i__ + 1, 1) - , ldx, &x_ref(1, i__), &c__1, &c_b5, &x_ref(i__ + 1, - i__), &c__1); - i__2 = *m - i__; - dscal_(&i__2, &taup[i__], &x_ref(i__ + 1, i__), &c__1); - -/* Update A(i+1:m,i) */ - - i__2 = *m - i__; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &a_ref(i__ + 1, 1) - , lda, &y_ref(i__, 1), ldy, &c_b5, &a_ref(i__ + 1, - i__), &c__1); - i__2 = *m - i__; - dgemv_("No transpose", &i__2, &i__, &c_b4, &x_ref(i__ + 1, 1), - ldx, &a_ref(1, i__), &c__1, &c_b5, &a_ref(i__ + 1, - i__), &c__1); - -/* Generate reflection Q(i) to annihilate A(i+2:m,i) - - Computing MIN */ - i__2 = i__ + 2; - i__3 = *m - i__; - dlarfg_(&i__3, &a_ref(i__ + 1, i__), &a_ref(min(i__2,*m), i__) - , &c__1, &tauq[i__]); - e[i__] = a_ref(i__ + 1, i__); - a_ref(i__ + 1, i__) = 1.; - -/* Compute Y(i+1:n,i) */ - - i__2 = *m - i__; - i__3 = *n - i__; - dgemv_("Transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1, i__ - + 1), lda, &a_ref(i__ + 1, i__), &c__1, &c_b16, & - y_ref(i__ + 1, i__), &c__1); - i__2 = *m - i__; - i__3 = i__ - 1; - dgemv_("Transpose", &i__2, &i__3, &c_b5, &a_ref(i__ + 1, 1), - lda, &a_ref(i__ + 1, i__), &c__1, &c_b16, &y_ref(1, - i__), &c__1); - i__2 = *n - i__; - i__3 = i__ - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b4, &y_ref(i__ + 1, 1) - , ldy, &y_ref(1, i__), &c__1, &c_b5, &y_ref(i__ + 1, - i__), &c__1); - i__2 = *m - i__; - dgemv_("Transpose", &i__2, &i__, &c_b5, &x_ref(i__ + 1, 1), - ldx, &a_ref(i__ + 1, i__), &c__1, &c_b16, &y_ref(1, - i__), &c__1); - i__2 = *n - i__; - dgemv_("Transpose", &i__, &i__2, &c_b4, &a_ref(1, i__ + 1), - lda, &y_ref(1, i__), &c__1, &c_b5, &y_ref(i__ + 1, - i__), &c__1); - i__2 = *n - i__; - dscal_(&i__2, &tauq[i__], &y_ref(i__ + 1, i__), &c__1); - } -/* L20: */ - } - } - return 0; - -/* End of DLABRD */ - -} /* dlabrd_ */ - -#undef y_ref -#undef x_ref -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlacon.c b/ext/f2c_lapack/dlacon.c deleted file mode 100644 index 2bc7054ab..000000000 --- a/ext/f2c_lapack/dlacon.c +++ /dev/null @@ -1,257 +0,0 @@ -/* dlacon.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static doublereal c_b11 = 1.; - -/* Subroutine */ int dlacon_(integer *n, doublereal *v, doublereal *x, - integer *isgn, doublereal *est, integer *kase) -{ - /* System generated locals */ - integer i__1; - doublereal d__1; - - /* Builtin functions */ - double d_sign(doublereal *, doublereal *); - integer i_dnnt(doublereal *); - - /* Local variables */ - static integer i__, j, iter; - static doublereal temp; - static integer jump; - extern doublereal dasum_(integer *, doublereal *, integer *); - static integer jlast; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); - extern integer idamax_(integer *, doublereal *, integer *); - static doublereal altsgn, estold; - - -/* -- LAPACK auxiliary routine (version 3.0) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ -/* Courant Institute, Argonne National Lab, and Rice University */ -/* February 29, 1992 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLACON estimates the 1-norm of a square, real matrix A. */ -/* Reverse communication is used for evaluating matrix-vector products. */ - -/* Arguments */ -/* ========= */ - -/* N (input) INTEGER */ -/* The order of the matrix. N >= 1. */ - -/* V (workspace) DOUBLE PRECISION array, dimension (N) */ -/* On the final return, V = A*W, where EST = norm(V)/norm(W) */ -/* (W is not returned). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On an intermediate return, X should be overwritten by */ -/* A * X, if KASE=1, */ -/* A' * X, if KASE=2, */ -/* and DLACON must be re-called with all the other parameters */ -/* unchanged. */ - -/* ISGN (workspace) INTEGER array, dimension (N) */ - -/* EST (output) DOUBLE PRECISION */ -/* An estimate (a lower bound) for norm(A). */ - -/* KASE (input/output) INTEGER */ -/* On the initial call to DLACON, KASE should be 0. */ -/* On an intermediate return, KASE will be 1 or 2, indicating */ -/* whether X should be overwritten by A * X or A' * X. */ -/* On the final return from DLACON, KASE will again be 0. */ - -/* Further Details */ -/* ======= ======= */ - -/* Contributed by Nick Higham, University of Manchester. */ -/* Originally named SONEST, dated March 16, 1988. */ - -/* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of */ -/* a real or complex matrix, with applications to condition estimation", */ -/* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Save statement .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - --isgn; - --x; - --v; - - /* Function Body */ - if (*kase == 0) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = 1. / (doublereal) (*n); -/* L10: */ - } - *kase = 1; - jump = 1; - return 0; - } - - switch (jump) { - case 1: goto L20; - case 2: goto L40; - case 3: goto L70; - case 4: goto L110; - case 5: goto L140; - } - -/* ................ ENTRY (JUMP = 1) */ -/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */ - -L20: - if (*n == 1) { - v[1] = x[1]; - *est = abs(v[1]); -/* ... QUIT */ - goto L150; - } - *est = dasum_(n, &x[1], &c__1); - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = d_sign(&c_b11, &x[i__]); - isgn[i__] = i_dnnt(&x[i__]); -/* L30: */ - } - *kase = 2; - jump = 2; - return 0; - -/* ................ ENTRY (JUMP = 2) */ -/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. */ - -L40: - j = idamax_(n, &x[1], &c__1); - iter = 2; - -/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */ - -L50: - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = 0.; -/* L60: */ - } - x[j] = 1.; - *kase = 1; - jump = 3; - return 0; - -/* ................ ENTRY (JUMP = 3) */ -/* X HAS BEEN OVERWRITTEN BY A*X. */ - -L70: - dcopy_(n, &x[1], &c__1, &v[1], &c__1); - estold = *est; - *est = dasum_(n, &v[1], &c__1); - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - d__1 = d_sign(&c_b11, &x[i__]); - if (i_dnnt(&d__1) != isgn[i__]) { - goto L90; - } -/* L80: */ - } -/* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. */ - goto L120; - -L90: -/* TEST FOR CYCLING. */ - if (*est <= estold) { - goto L120; - } - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = d_sign(&c_b11, &x[i__]); - isgn[i__] = i_dnnt(&x[i__]); -/* L100: */ - } - *kase = 2; - jump = 4; - return 0; - -/* ................ ENTRY (JUMP = 4) */ -/* X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. */ - -L110: - jlast = j; - j = idamax_(n, &x[1], &c__1); - if (x[jlast] != (d__1 = x[j], abs(d__1)) && iter < 5) { - ++iter; - goto L50; - } - -/* ITERATION COMPLETE. FINAL STAGE. */ - -L120: - altsgn = 1.; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - x[i__] = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + - 1.); - altsgn = -altsgn; -/* L130: */ - } - *kase = 1; - jump = 5; - return 0; - -/* ................ ENTRY (JUMP = 5) */ -/* X HAS BEEN OVERWRITTEN BY A*X. */ - -L140: - temp = dasum_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.; - if (temp > *est) { - dcopy_(n, &x[1], &c__1, &v[1], &c__1); - *est = temp; - } - -L150: - *kase = 0; - return 0; - -/* End of DLACON */ - -} /* dlacon_ */ - diff --git a/ext/f2c_lapack/dlacpy.c b/ext/f2c_lapack/dlacpy.c deleted file mode 100644 index f1bf61a82..000000000 --- a/ext/f2c_lapack/dlacpy.c +++ /dev/null @@ -1,114 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlacpy_(char *uplo, integer *m, integer *n, doublereal * - a, integer *lda, doublereal *b, integer *ldb) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - February 29, 1992 - - - Purpose - ======= - - DLACPY copies all or part of a two-dimensional matrix A to another - matrix B. - - Arguments - ========= - - UPLO (input) CHARACTER*1 - Specifies the part of the matrix A to be copied to B. - = 'U': Upper triangular part - = 'L': Lower triangular part - Otherwise: All of the matrix A - - M (input) INTEGER - The number of rows of the matrix A. M >= 0. - - N (input) INTEGER - The number of columns of the matrix A. N >= 0. - - A (input) DOUBLE PRECISION array, dimension (LDA,N) - The m by n matrix A. If UPLO = 'U', only the upper triangle - or trapezoid is accessed; if UPLO = 'L', only the lower - triangle or trapezoid is accessed. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - B (output) DOUBLE PRECISION array, dimension (LDB,N) - On exit, B = A in the locations specified by UPLO. - - LDB (input) INTEGER - The leading dimension of the array B. LDB >= max(1,M). - - ===================================================================== - - - Parameter adjustments */ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; - /* Local variables */ - static integer i__, j; - extern logical lsame_(char *, char *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -#define b_ref(a_1,a_2) b[(a_2)*b_dim1 + a_1] - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1 * 1; - b -= b_offset; - - /* Function Body */ - if (lsame_(uplo, "U")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = min(j,*m); - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = a_ref(i__, j); -/* L10: */ - } -/* L20: */ - } - } else if (lsame_(uplo, "L")) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { - b_ref(i__, j) = a_ref(i__, j); -/* L30: */ - } -/* L40: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - b_ref(i__, j) = a_ref(i__, j); -/* L50: */ - } -/* L60: */ - } - } - return 0; - -/* End of DLACPY */ - -} /* dlacpy_ */ - -#undef b_ref -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlamch.c b/ext/f2c_lapack/dlamch.c deleted file mode 100644 index 658417e12..000000000 --- a/ext/f2c_lapack/dlamch.c +++ /dev/null @@ -1,975 +0,0 @@ -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" -#include "stdio.h" - -doublereal dlamch_(char *cmach) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1992 - - - Purpose - ======= - - DLAMCH determines double precision machine parameters. - - Arguments - ========= - - CMACH (input) CHARACTER*1 - Specifies the value to be returned by DLAMCH: - = 'E' or 'e', DLAMCH := eps - = 'S' or 's , DLAMCH := sfmin - = 'B' or 'b', DLAMCH := base - = 'P' or 'p', DLAMCH := eps*base - = 'N' or 'n', DLAMCH := t - = 'R' or 'r', DLAMCH := rnd - = 'M' or 'm', DLAMCH := emin - = 'U' or 'u', DLAMCH := rmin - = 'L' or 'l', DLAMCH := emax - = 'O' or 'o', DLAMCH := rmax - - where - - eps = relative machine precision - sfmin = safe minimum, such that 1/sfmin does not overflow - base = base of the machine - prec = eps*base - t = number of (base) digits in the mantissa - rnd = 1.0 when rounding occurs in addition, 0.0 otherwise - emin = minimum exponent before (gradual) underflow - rmin = underflow threshold - base**(emin-1) - emax = largest exponent before overflow - rmax = overflow threshold - (base**emax)*(1-eps) - - ===================================================================== -*/ -/* >>Start of File<< - Initialized data */ - static logical first = TRUE_; - /* System generated locals */ - integer i__1; - doublereal ret_val; - /* Builtin functions */ - double pow_di(doublereal *, integer *); - /* Local variables */ - static doublereal base; - static integer beta; - static doublereal emin, prec, emax; - static integer imin, imax; - static logical lrnd; - static doublereal rmin, rmax, t, rmach; - extern logical lsame_(char *, char *); - static doublereal small, sfmin; - extern /* Subroutine */ int dlamc2_(integer *, integer *, logical *, - doublereal *, integer *, doublereal *, integer *, doublereal *); - static integer it; - static doublereal rnd, eps; - - - - if (first) { - first = FALSE_; - dlamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax); - base = (doublereal) beta; - t = (doublereal) it; - if (lrnd) { - rnd = 1.; - i__1 = 1 - it; - eps = pow_di(&base, &i__1) / 2; - } else { - rnd = 0.; - i__1 = 1 - it; - eps = pow_di(&base, &i__1); - } - prec = eps * base; - emin = (doublereal) imin; - emax = (doublereal) imax; - sfmin = rmin; - small = 1. / rmax; - if (small >= sfmin) { - -/* Use SMALL plus a bit, to avoid the possibility of rou -nding - causing overflow when computing 1/sfmin. */ - - sfmin = small * (eps + 1.); - } - } - - if (lsame_(cmach, "E")) { - rmach = eps; - } else if (lsame_(cmach, "S")) { - rmach = sfmin; - } else if (lsame_(cmach, "B")) { - rmach = base; - } else if (lsame_(cmach, "P")) { - rmach = prec; - } else if (lsame_(cmach, "N")) { - rmach = t; - } else if (lsame_(cmach, "R")) { - rmach = rnd; - } else if (lsame_(cmach, "M")) { - rmach = emin; - } else if (lsame_(cmach, "U")) { - rmach = rmin; - } else if (lsame_(cmach, "L")) { - rmach = emax; - } else if (lsame_(cmach, "O")) { - rmach = rmax; - } - - ret_val = rmach; - return ret_val; - -/* End of DLAMCH */ - -} /* dlamch_ */ - -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlamc1_(integer *beta, integer *t, logical *rnd, logical - *ieee1) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1992 - - - Purpose - ======= - - DLAMC1 determines the machine parameters given by BETA, T, RND, and - IEEE1. - - Arguments - ========= - - BETA (output) INTEGER - The base of the machine. - - T (output) INTEGER - The number of ( BETA ) digits in the mantissa. - - RND (output) LOGICAL - Specifies whether proper rounding ( RND = .TRUE. ) or - chopping ( RND = .FALSE. ) occurs in addition. This may not - - be a reliable guide to the way in which the machine performs - - its arithmetic. - - IEEE1 (output) LOGICAL - Specifies whether rounding appears to be done in the IEEE - 'round to nearest' style. - - Further Details - =============== - - The routine is based on the routine ENVRON by Malcolm and - incorporates suggestions by Gentleman and Marovich. See - - Malcolm M. A. (1972) Algorithms to reveal properties of - floating-point arithmetic. Comms. of the ACM, 15, 949-951. - - Gentleman W. M. and Marovich S. B. (1974) More on algorithms - that reveal properties of floating point arithmetic units. - Comms. of the ACM, 17, 276-277. - - ===================================================================== -*/ - /* Initialized data */ - static logical first = TRUE_; - /* System generated locals */ - doublereal d__1, d__2; - /* Local variables */ - static logical lrnd; - static doublereal a, b, c, f; - static integer lbeta; - static doublereal savec; - extern doublereal dlamc3_(doublereal *, doublereal *); - static logical lieee1; - static doublereal t1, t2; - static integer lt; - static doublereal one, qtr; - - - - if (first) { - first = FALSE_; - one = 1.; - -/* LBETA, LIEEE1, LT and LRND are the local values of BE -TA, - IEEE1, T and RND. - - Throughout this routine we use the function DLAMC3 to ens -ure - that relevant values are stored and not held in registers, - or - are not affected by optimizers. - - Compute a = 2.0**m with the smallest positive integer m s -uch - that - - fl( a + 1.0 ) = a. */ - - a = 1.; - c = 1.; - -/* + WHILE( C.EQ.ONE )LOOP */ -L10: - if (c == one) { - a *= 2; - c = dlamc3_(&a, &one); - d__1 = -a; - c = dlamc3_(&c, &d__1); - goto L10; - } -/* + END WHILE - - Now compute b = 2.0**m with the smallest positive integer -m - such that - - fl( a + b ) .gt. a. */ - - b = 1.; - c = dlamc3_(&a, &b); - -/* + WHILE( C.EQ.A )LOOP */ -L20: - if (c == a) { - b *= 2; - c = dlamc3_(&a, &b); - goto L20; - } -/* + END WHILE - - Now compute the base. a and c are neighbouring floating po -int - numbers in the interval ( beta**t, beta**( t + 1 ) ) and - so - their difference is beta. Adding 0.25 to c is to ensure that - it - is truncated to beta and not ( beta - 1 ). */ - - qtr = one / 4; - savec = c; - d__1 = -a; - c = dlamc3_(&c, &d__1); - lbeta = (integer) (c + qtr); - -/* Now determine whether rounding or chopping occurs, by addin -g a - bit less than beta/2 and a bit more than beta/2 to - a. */ - - b = (doublereal) lbeta; - d__1 = b / 2; - d__2 = -b / 100; - f = dlamc3_(&d__1, &d__2); - c = dlamc3_(&f, &a); - if (c == a) { - lrnd = TRUE_; - } else { - lrnd = FALSE_; - } - d__1 = b / 2; - d__2 = b / 100; - f = dlamc3_(&d__1, &d__2); - c = dlamc3_(&f, &a); - if (lrnd && c == a) { - lrnd = FALSE_; - } - -/* Try and decide whether rounding is done in the IEEE 'round - to - nearest' style. B/2 is half a unit in the last place of the -two - numbers A and SAVEC. Furthermore, A is even, i.e. has last -bit - zero, and SAVEC is odd. Thus adding B/2 to A should not cha -nge - A, but adding B/2 to SAVEC should change SAVEC. */ - - d__1 = b / 2; - t1 = dlamc3_(&d__1, &a); - d__1 = b / 2; - t2 = dlamc3_(&d__1, &savec); - lieee1 = t1 == a && t2 > savec && lrnd; - -/* Now find the mantissa, t. It should be the integer part - of - log to the base beta of a, however it is safer to determine - t - by powering. So we find t as the smallest positive integer -for - which - - fl( beta**t + 1.0 ) = 1.0. */ - - lt = 0; - a = 1.; - c = 1.; - -/* + WHILE( C.EQ.ONE )LOOP */ -L30: - if (c == one) { - ++lt; - a *= lbeta; - c = dlamc3_(&a, &one); - d__1 = -a; - c = dlamc3_(&c, &d__1); - goto L30; - } -/* + END WHILE */ - - } - - *beta = lbeta; - *t = lt; - *rnd = lrnd; - *ieee1 = lieee1; - return 0; - -/* End of DLAMC1 */ - -} /* dlamc1_ */ - -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlamc2_(integer *beta, integer *t, logical *rnd, - doublereal *eps, integer *emin, doublereal *rmin, integer *emax, - doublereal *rmax) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1992 - - - Purpose - ======= - - DLAMC2 determines the machine parameters specified in its argument - list. - - Arguments - ========= - - BETA (output) INTEGER - The base of the machine. - - T (output) INTEGER - The number of ( BETA ) digits in the mantissa. - - RND (output) LOGICAL - Specifies whether proper rounding ( RND = .TRUE. ) or - chopping ( RND = .FALSE. ) occurs in addition. This may not - - be a reliable guide to the way in which the machine performs - - its arithmetic. - - EPS (output) DOUBLE PRECISION - The smallest positive number such that - - fl( 1.0 - EPS ) .LT. 1.0, - - where fl denotes the computed value. - - EMIN (output) INTEGER - The minimum exponent before (gradual) underflow occurs. - - RMIN (output) DOUBLE PRECISION - The smallest normalized number for the machine, given by - BASE**( EMIN - 1 ), where BASE is the floating point value - - of BETA. - - EMAX (output) INTEGER - The maximum exponent before overflow occurs. - - RMAX (output) DOUBLE PRECISION - The largest positive number for the machine, given by - BASE**EMAX * ( 1 - EPS ), where BASE is the floating point - - value of BETA. - - Further Details - =============== - - The computation of EPS is based on a routine PARANOIA by - W. Kahan of the University of California at Berkeley. - - ===================================================================== -*/ - /* Table of constant values */ - static integer c__1 = 1; - - /* Initialized data */ - static logical first = TRUE_; - static logical iwarn = FALSE_; - /* System generated locals */ - integer i__1; - doublereal d__1, d__2, d__3, d__4, d__5; - /* Builtin functions */ - double pow_di(doublereal *, integer *); - /* Local variables */ - static logical ieee; - static doublereal half; - static logical lrnd; - static doublereal leps, zero, a, b, c; - static integer i, lbeta; - static doublereal rbase; - static integer lemin, lemax, gnmin; - static doublereal small; - static integer gpmin; - static doublereal third, lrmin, lrmax, sixth; - extern /* Subroutine */ int dlamc1_(integer *, integer *, logical *, - logical *); - extern doublereal dlamc3_(doublereal *, doublereal *); - static logical lieee1; - extern /* Subroutine */ int dlamc4_(integer *, doublereal *, integer *), - dlamc5_(integer *, integer *, integer *, logical *, integer *, - doublereal *); - static integer lt, ngnmin, ngpmin; - static doublereal one, two; - - - - if (first) { - first = FALSE_; - zero = 0.; - one = 1.; - two = 2.; - -/* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values - of - BETA, T, RND, EPS, EMIN and RMIN. - - Throughout this routine we use the function DLAMC3 to ens -ure - that relevant values are stored and not held in registers, - or - are not affected by optimizers. - - DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. -*/ - - dlamc1_(&lbeta, <, &lrnd, &lieee1); - -/* Start to find EPS. */ - - b = (doublereal) lbeta; - i__1 = -lt; - a = pow_di(&b, &i__1); - leps = a; - -/* Try some tricks to see whether or not this is the correct E -PS. */ - - b = two / 3; - half = one / 2; - d__1 = -half; - sixth = dlamc3_(&b, &d__1); - third = dlamc3_(&sixth, &sixth); - d__1 = -half; - b = dlamc3_(&third, &d__1); - b = dlamc3_(&b, &sixth); - b = abs(b); - if (b < leps) { - b = leps; - } - - leps = 1.; - -/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */ -L10: - if (leps > b && b > zero) { - leps = b; - d__1 = half * leps; -/* Computing 5th power */ - d__3 = two, d__4 = d__3, d__3 *= d__3; -/* Computing 2nd power */ - d__5 = leps; - d__2 = d__4 * (d__3 * d__3) * (d__5 * d__5); - c = dlamc3_(&d__1, &d__2); - d__1 = -c; - c = dlamc3_(&half, &d__1); - b = dlamc3_(&half, &c); - d__1 = -b; - c = dlamc3_(&half, &d__1); - b = dlamc3_(&half, &c); - goto L10; - } -/* + END WHILE */ - - if (a < leps) { - leps = a; - } - -/* Computation of EPS complete. - - Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3 -)). - Keep dividing A by BETA until (gradual) underflow occurs. T -his - is detected when we cannot recover the previous A. */ - - rbase = one / lbeta; - small = one; - for (i = 1; i <= 3; ++i) { - d__1 = small * rbase; - small = dlamc3_(&d__1, &zero); -/* L20: */ - } - a = dlamc3_(&one, &small); - dlamc4_(&ngpmin, &one, &lbeta); - d__1 = -one; - dlamc4_(&ngnmin, &d__1, &lbeta); - dlamc4_(&gpmin, &a, &lbeta); - d__1 = -a; - dlamc4_(&gnmin, &d__1, &lbeta); - ieee = FALSE_; - - if (ngpmin == ngnmin && gpmin == gnmin) { - if (ngpmin == gpmin) { - lemin = ngpmin; -/* ( Non twos-complement machines, no gradual under -flow; - e.g., VAX ) */ - } else if (gpmin - ngpmin == 3) { - lemin = ngpmin - 1 + lt; - ieee = TRUE_; -/* ( Non twos-complement machines, with gradual und -erflow; - e.g., IEEE standard followers ) */ - } else { - lemin = min(ngpmin,gpmin); -/* ( A guess; no known machine ) */ - iwarn = TRUE_; - } - - } else if (ngpmin == gpmin && ngnmin == gnmin) { - if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) { - lemin = max(ngpmin,ngnmin); -/* ( Twos-complement machines, no gradual underflow -; - e.g., CYBER 205 ) */ - } else { - lemin = min(ngpmin,ngnmin); -/* ( A guess; no known machine ) */ - iwarn = TRUE_; - } - - } else if ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1 && gpmin == gnmin) - { - if (gpmin - min(ngpmin,ngnmin) == 3) { - lemin = max(ngpmin,ngnmin) - 1 + lt; -/* ( Twos-complement machines with gradual underflo -w; - no known machine ) */ - } else { - lemin = min(ngpmin,ngnmin); -/* ( A guess; no known machine ) */ - iwarn = TRUE_; - } - - } else { -/* Computing MIN */ - i__1 = min(ngpmin,ngnmin), i__1 = min(i__1,gpmin); - lemin = min(i__1,gnmin); -/* ( A guess; no known machine ) */ - iwarn = TRUE_; - } -/* ** - Comment out this if block if EMIN is ok */ - if (iwarn) { - first = TRUE_; - printf("\n\n WARNING. The value EMIN may be incorrect:- "); - printf("EMIN = %8i\n",lemin); - printf("If, after inspection, the value EMIN looks acceptable"); - printf("please comment out \n the IF block as marked within the"); - printf("code of routine DLAMC2, \n otherwise supply EMIN"); - printf("explicitly.\n"); - } -/* ** - - Assume IEEE arithmetic if we found denormalised numbers abo -ve, - or if arithmetic seems to round in the IEEE style, determi -ned - in routine DLAMC1. A true IEEE machine should have both thi -ngs - true; however, faulty machines may have one or the other. */ - - ieee = ieee || lieee1; - -/* Compute RMIN by successive division by BETA. We could comp -ute - RMIN as BASE**( EMIN - 1 ), but some machines underflow dur -ing - this computation. */ - - lrmin = 1.; - i__1 = 1 - lemin; - for (i = 1; i <= 1-lemin; ++i) { - d__1 = lrmin * rbase; - lrmin = dlamc3_(&d__1, &zero); -/* L30: */ - } - -/* Finally, call DLAMC5 to compute EMAX and RMAX. */ - - dlamc5_(&lbeta, <, &lemin, &ieee, &lemax, &lrmax); - } - - *beta = lbeta; - *t = lt; - *rnd = lrnd; - *eps = leps; - *emin = lemin; - *rmin = lrmin; - *emax = lemax; - *rmax = lrmax; - - return 0; - - -/* End of DLAMC2 */ - -} /* dlamc2_ */ - -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -doublereal dlamc3_(doublereal *a, doublereal *b) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1992 - - - Purpose - ======= - - DLAMC3 is intended to force A and B to be stored prior to doing - - the addition of A and B , for use in situations where optimizers - - might hold one of these in a register. - - Arguments - ========= - - A, B (input) DOUBLE PRECISION - The values A and B. - - ===================================================================== -*/ -/* >>Start of File<< - System generated locals */ - doublereal ret_val; - - - - ret_val = *a + *b; - - return ret_val; - -/* End of DLAMC3 */ - -} /* dlamc3_ */ - -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlamc4_(integer *emin, doublereal *start, integer *base) -{ -/* -- LAPACK auxiliary routine (version 2.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1992 - - - Purpose - ======= - - DLAMC4 is a service routine for DLAMC2. - - Arguments - ========= - - EMIN (output) EMIN - The minimum exponent before (gradual) underflow, computed by - - setting A = START and dividing by BASE until the previous A - can not be recovered. - - START (input) DOUBLE PRECISION - The starting point for determining EMIN. - - BASE (input) INTEGER - The base of the machine. - - ===================================================================== -*/ - /* System generated locals */ - integer i__1; - doublereal d__1; - /* Local variables */ - static doublereal zero, a; - static integer i; - static doublereal rbase, b1, b2, c1, c2, d1, d2; - extern doublereal dlamc3_(doublereal *, doublereal *); - static doublereal one; - - - - a = *start; - one = 1.; - rbase = one / *base; - zero = 0.; - *emin = 1; - d__1 = a * rbase; - b1 = dlamc3_(&d__1, &zero); - c1 = a; - c2 = a; - d1 = a; - d2 = a; -/* + WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. - $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP */ -L10: - if (c1 == a && c2 == a && d1 == a && d2 == a) { - --(*emin); - a = b1; - d__1 = a / *base; - b1 = dlamc3_(&d__1, &zero); - d__1 = b1 * *base; - c1 = dlamc3_(&d__1, &zero); - d1 = zero; - i__1 = *base; - for (i = 1; i <= *base; ++i) { - d1 += b1; -/* L20: */ - } - d__1 = a * rbase; - b2 = dlamc3_(&d__1, &zero); - d__1 = b2 / rbase; - c2 = dlamc3_(&d__1, &zero); - d2 = zero; - i__1 = *base; - for (i = 1; i <= *base; ++i) { - d2 += b2; -/* L30: */ - } - goto L10; - } -/* + END WHILE */ - - return 0; - -/* End of DLAMC4 */ - -} /* dlamc4_ */ - -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlamc5_(integer *beta, integer *p, integer *emin, - logical *ieee, integer *emax, doublereal *rmax) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1992 - - - Purpose - ======= - - DLAMC5 attempts to compute RMAX, the largest machine floating-point - number, without overflow. It assumes that EMAX + abs(EMIN) sum - approximately to a power of 2. It will fail on machines where this - assumption does not hold, for example, the Cyber 205 (EMIN = -28625, - - EMAX = 28718). It will also fail if the value supplied for EMIN is - too large (i.e. too close to zero), probably with overflow. - - Arguments - ========= - - BETA (input) INTEGER - The base of floating-point arithmetic. - - P (input) INTEGER - The number of base BETA digits in the mantissa of a - floating-point value. - - EMIN (input) INTEGER - The minimum exponent before (gradual) underflow. - - IEEE (input) LOGICAL - A logical flag specifying whether or not the arithmetic - system is thought to comply with the IEEE standard. - - EMAX (output) INTEGER - The largest exponent before overflow - - RMAX (output) DOUBLE PRECISION - The largest machine floating-point number. - - ===================================================================== - - - - First compute LEXP and UEXP, two powers of 2 that bound - abs(EMIN). We then assume that EMAX + abs(EMIN) will sum - approximately to the bound that is closest to abs(EMIN). - (EMAX is the exponent of the required number RMAX). */ - /* Table of constant values */ - static doublereal c_b5 = 0.; - - /* System generated locals */ - integer i__1; - doublereal d__1; - /* Local variables */ - static integer lexp; - static doublereal oldy; - static integer uexp, i; - static doublereal y, z; - static integer nbits; - extern doublereal dlamc3_(doublereal *, doublereal *); - static doublereal recbas; - static integer exbits, expsum, try__; - - - - lexp = 1; - exbits = 1; -L10: - try__ = lexp << 1; - if (try__ <= -(*emin)) { - lexp = try__; - ++exbits; - goto L10; - } - if (lexp == -(*emin)) { - uexp = lexp; - } else { - uexp = try__; - ++exbits; - } - -/* Now -LEXP is less than or equal to EMIN, and -UEXP is greater - than or equal to EMIN. EXBITS is the number of bits needed to - store the exponent. */ - - if (uexp + *emin > -lexp - *emin) { - expsum = lexp << 1; - } else { - expsum = uexp << 1; - } - -/* EXPSUM is the exponent range, approximately equal to - EMAX - EMIN + 1 . */ - - *emax = expsum + *emin - 1; - nbits = exbits + 1 + *p; - -/* NBITS is the total number of bits needed to store a - floating-point number. */ - - if (nbits % 2 == 1 && *beta == 2) { - -/* Either there are an odd number of bits used to store a - floating-point number, which is unlikely, or some bits are - - not used in the representation of numbers, which is possible -, - (e.g. Cray machines) or the mantissa has an implicit bit, - (e.g. IEEE machines, Dec Vax machines), which is perhaps the - - most likely. We have to assume the last alternative. - If this is true, then we need to reduce EMAX by one because - - there must be some way of representing zero in an implicit-b -it - system. On machines like Cray, we are reducing EMAX by one - - unnecessarily. */ - - --(*emax); - } - - if (*ieee) { - -/* Assume we are on an IEEE machine which reserves one exponent - - for infinity and NaN. */ - - --(*emax); - } - -/* Now create RMAX, the largest machine number, which should - be equal to (1.0 - BETA**(-P)) * BETA**EMAX . - - First compute 1.0 - BETA**(-P), being careful that the - result is less than 1.0 . */ - - recbas = 1. / *beta; - z = *beta - 1.; - y = 0.; - i__1 = *p; - for (i = 1; i <= *p; ++i) { - z *= recbas; - if (y < 1.) { - oldy = y; - } - y = dlamc3_(&y, &z); -/* L20: */ - } - if (y >= 1.) { - y = oldy; - } - -/* Now multiply by BETA**EMAX to get RMAX. */ - - i__1 = *emax; - for (i = 1; i <= *emax; ++i) { - d__1 = y * *beta; - y = dlamc3_(&d__1, &c_b5); -/* L30: */ - } - - *rmax = y; - return 0; - -/* End of DLAMC5 */ - -} /* dlamc5_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlange.c b/ext/f2c_lapack/dlange.c deleted file mode 100644 index dd6af160c..000000000 --- a/ext/f2c_lapack/dlange.c +++ /dev/null @@ -1,182 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer - *lda, doublereal *work) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1992 - - - Purpose - ======= - - DLANGE returns the value of the one norm, or the Frobenius norm, or - the infinity norm, or the element of largest absolute value of a - real matrix A. - - Description - =========== - - DLANGE returns the value - - DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' - ( - ( norm1(A), NORM = '1', 'O' or 'o' - ( - ( normI(A), NORM = 'I' or 'i' - ( - ( normF(A), NORM = 'F', 'f', 'E' or 'e' - - where norm1 denotes the one norm of a matrix (maximum column sum), - normI denotes the infinity norm of a matrix (maximum row sum) and - normF denotes the Frobenius norm of a matrix (square root of sum of - squares). Note that max(abs(A(i,j))) is not a matrix norm. - - Arguments - ========= - - NORM (input) CHARACTER*1 - Specifies the value to be returned in DLANGE as described - above. - - M (input) INTEGER - The number of rows of the matrix A. M >= 0. When M = 0, - DLANGE is set to zero. - - N (input) INTEGER - The number of columns of the matrix A. N >= 0. When N = 0, - DLANGE is set to zero. - - A (input) DOUBLE PRECISION array, dimension (LDA,N) - The m by n matrix A. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(M,1). - - WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), - where LWORK >= M when NORM = 'I'; otherwise, WORK is not - referenced. - - ===================================================================== - - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - doublereal ret_val, d__1, d__2, d__3; - /* Builtin functions */ - double sqrt(doublereal); - /* Local variables */ - static integer i__, j; - static doublereal scale; - extern logical lsame_(char *, char *); - static doublereal value; - extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, - doublereal *, doublereal *); - static doublereal sum; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --work; - - /* Function Body */ - if (min(*m,*n) == 0) { - value = 0.; - } else if (lsame_(norm, "M")) { - -/* Find max(abs(A(i,j))). */ - - value = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a_ref(i__, j), abs(d__1)); - value = max(d__2,d__3); -/* L10: */ - } -/* L20: */ - } - } else if (lsame_(norm, "O") || *(unsigned char *) - norm == '1') { - -/* Find norm1(A). */ - - value = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - sum = 0.; - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - sum += (d__1 = a_ref(i__, j), abs(d__1)); -/* L30: */ - } - value = max(value,sum); -/* L40: */ - } - } else if (lsame_(norm, "I")) { - -/* Find normI(A). */ - - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L50: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] += (d__1 = a_ref(i__, j), abs(d__1)); -/* L60: */ - } -/* L70: */ - } - value = 0.; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = value, d__2 = work[i__]; - value = max(d__1,d__2); -/* L80: */ - } - } else if (lsame_(norm, "F") || lsame_(norm, "E")) { - -/* Find normF(A). */ - - scale = 0.; - sum = 1.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - dlassq_(m, &a_ref(1, j), &c__1, &scale, &sum); -/* L90: */ - } - value = scale * sqrt(sum); - } - - ret_val = value; - return ret_val; - -/* End of DLANGE */ - -} /* dlange_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlantr.c b/ext/f2c_lapack/dlantr.c deleted file mode 100644 index 17a0e0724..000000000 --- a/ext/f2c_lapack/dlantr.c +++ /dev/null @@ -1,401 +0,0 @@ -/* dlantr.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -doublereal dlantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, - doublereal *a, integer *lda, doublereal *work, ftnlen norm_len, - ftnlen uplo_len, ftnlen diag_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - doublereal ret_val, d__1, d__2, d__3; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - static integer i__, j; - static doublereal sum, scale; - static logical udiag; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - static doublereal value; - extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, - doublereal *, doublereal *); - - -/* -- LAPACK auxiliary routine (version 3.0) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ -/* Courant Institute, Argonne National Lab, and Rice University */ -/* October 31, 1992 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLANTR returns the value of the one norm, or the Frobenius norm, or */ -/* the infinity norm, or the element of largest absolute value of a */ -/* trapezoidal or triangular matrix A. */ - -/* Description */ -/* =========== */ - -/* DLANTR returns the value */ - -/* DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm' */ -/* ( */ -/* ( norm1(A), NORM = '1', 'O' or 'o' */ -/* ( */ -/* ( normI(A), NORM = 'I' or 'i' */ -/* ( */ -/* ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ - -/* where norm1 denotes the one norm of a matrix (maximum column sum), */ -/* normI denotes the infinity norm of a matrix (maximum row sum) and */ -/* normF denotes the Frobenius norm of a matrix (square root of sum of */ -/* squares). Note that max(abs(A(i,j))) is not a matrix norm. */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies the value to be returned in DLANTR as described */ -/* above. */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the matrix A is upper or lower trapezoidal. */ -/* = 'U': Upper trapezoidal */ -/* = 'L': Lower trapezoidal */ -/* Note that A is triangular instead of trapezoidal if M = N. */ - -/* DIAG (input) CHARACTER*1 */ -/* Specifies whether or not the matrix A has unit diagonal. */ -/* = 'N': Non-unit diagonal */ -/* = 'U': Unit diagonal */ - -/* M (input) INTEGER */ -/* The number of rows of the matrix A. M >= 0, and if */ -/* UPLO = 'U', M <= N. When M = 0, DLANTR is set to zero. */ - -/* N (input) INTEGER */ -/* The number of columns of the matrix A. N >= 0, and if */ -/* UPLO = 'L', N <= M. When N = 0, DLANTR is set to zero. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The trapezoidal matrix A (A is triangular if M = N). */ -/* If UPLO = 'U', the leading m by n upper trapezoidal part of */ -/* the array A contains the upper trapezoidal matrix, and the */ -/* strictly lower triangular part of A is not referenced. */ -/* If UPLO = 'L', the leading m by n lower trapezoidal part of */ -/* the array A contains the lower trapezoidal matrix, and the */ -/* strictly upper triangular part of A is not referenced. Note */ -/* that when DIAG = 'U', the diagonal elements of A are not */ -/* referenced and are assumed to be one. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(M,1). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), */ -/* where LWORK >= M when NORM = 'I'; otherwise, WORK is not */ -/* referenced. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --work; - - /* Function Body */ - if (min(*m,*n) == 0) { - value = 0.; - } else if (lsame_(norm, "M", (ftnlen)1, (ftnlen)1)) { - -/* Find max(abs(A(i,j))). */ - - if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { - value = 1.; - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = *m, i__4 = j - 1; - i__2 = min(i__3,i__4); - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs( - d__1)); - value = max(d__2,d__3); -/* L10: */ - } -/* L20: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j + 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs( - d__1)); - value = max(d__2,d__3); -/* L30: */ - } -/* L40: */ - } - } - } else { - value = 0.; - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = min(*m,j); - for (i__ = 1; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs( - d__1)); - value = max(d__2,d__3); -/* L50: */ - } -/* L60: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { -/* Computing MAX */ - d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs( - d__1)); - value = max(d__2,d__3); -/* L70: */ - } -/* L80: */ - } - } - } - } else if (lsame_(norm, "O", (ftnlen)1, (ftnlen)1) || *(unsigned char *) - norm == '1') { - -/* Find norm1(A). */ - - value = 0.; - udiag = lsame_(diag, "U", (ftnlen)1, (ftnlen)1); - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (udiag && j <= *m) { - sum = 1.; - i__2 = j - 1; - for (i__ = 1; i__ <= i__2; ++i__) { - sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L90: */ - } - } else { - sum = 0.; - i__2 = min(*m,j); - for (i__ = 1; i__ <= i__2; ++i__) { - sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L100: */ - } - } - value = max(value,sum); -/* L110: */ - } - } else { - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (udiag) { - sum = 1.; - i__2 = *m; - for (i__ = j + 1; i__ <= i__2; ++i__) { - sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L120: */ - } - } else { - sum = 0.; - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { - sum += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L130: */ - } - } - value = max(value,sum); -/* L140: */ - } - } - } else if (lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) { - -/* Find normI(A). */ - - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 1.; -/* L150: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = *m, i__4 = j - 1; - i__2 = min(i__3,i__4); - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L160: */ - } -/* L170: */ - } - } else { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L180: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = min(*m,j); - for (i__ = 1; i__ <= i__2; ++i__) { - work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L190: */ - } -/* L200: */ - } - } - } else { - if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 1.; -/* L210: */ - } - i__1 = *m; - for (i__ = *n + 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L220: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j + 1; i__ <= i__2; ++i__) { - work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L230: */ - } -/* L240: */ - } - } else { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - work[i__] = 0.; -/* L250: */ - } - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { - work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1)); -/* L260: */ - } -/* L270: */ - } - } - } - value = 0.; - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = value, d__2 = work[i__]; - value = max(d__1,d__2); -/* L280: */ - } - } else if (lsame_(norm, "F", (ftnlen)1, (ftnlen)1) || lsame_(norm, "E", ( - ftnlen)1, (ftnlen)1)) { - -/* Find normF(A). */ - - if (lsame_(uplo, "U", (ftnlen)1, (ftnlen)1)) { - if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { - scale = 1.; - sum = (doublereal) min(*m,*n); - i__1 = *n; - for (j = 2; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = *m, i__4 = j - 1; - i__2 = min(i__3,i__4); - dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); -/* L290: */ - } - } else { - scale = 0.; - sum = 1.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = min(*m,j); - dlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, &scale, &sum); -/* L300: */ - } - } - } else { - if (lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { - scale = 1.; - sum = (doublereal) min(*m,*n); - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m - j; -/* Computing MIN */ - i__3 = *m, i__4 = j + 1; - dlassq_(&i__2, &a[min(i__3,i__4) + j * a_dim1], &c__1, & - scale, &sum); -/* L310: */ - } - } else { - scale = 0.; - sum = 1.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m - j + 1; - dlassq_(&i__2, &a[j + j * a_dim1], &c__1, &scale, &sum); -/* L320: */ - } - } - } - value = scale * sqrt(sum); - } - - ret_val = value; - return ret_val; - -/* End of DLANTR */ - -} /* dlantr_ */ - diff --git a/ext/f2c_lapack/dlapy2.c b/ext/f2c_lapack/dlapy2.c deleted file mode 100644 index a5ef8bdea..000000000 --- a/ext/f2c_lapack/dlapy2.c +++ /dev/null @@ -1,57 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -doublereal dlapy2_(doublereal *x, doublereal *y) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1992 - - - Purpose - ======= - - DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary - overflow. - - Arguments - ========= - - X (input) DOUBLE PRECISION - Y (input) DOUBLE PRECISION - X and Y specify the values x and y. - - ===================================================================== */ - /* System generated locals */ - doublereal ret_val, d__1; - /* Builtin functions */ - double sqrt(doublereal); - /* Local variables */ - static doublereal xabs, yabs, w, z__; - - - - xabs = abs(*x); - yabs = abs(*y); - w = max(xabs,yabs); - z__ = min(xabs,yabs); - if (z__ == 0.) { - ret_val = w; - } else { -/* Computing 2nd power */ - d__1 = z__ / w; - ret_val = w * sqrt(d__1 * d__1 + 1.); - } - return ret_val; - -/* End of DLAPY2 */ - -} /* dlapy2_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlarf.c b/ext/f2c_lapack/dlarf.c deleted file mode 100644 index 695fee883..000000000 --- a/ext/f2c_lapack/dlarf.c +++ /dev/null @@ -1,138 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlarf_(char *side, integer *m, integer *n, doublereal *v, - integer *incv, doublereal *tau, doublereal *c__, integer *ldc, - doublereal *work) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - February 29, 1992 - - - Purpose - ======= - - DLARF applies a real elementary reflector H to a real m by n matrix - C, from either the left or the right. H is represented in the form - - H = I - tau * v * v' - - where tau is a real scalar and v is a real vector. - - If tau = 0, then H is taken to be the unit matrix. - - Arguments - ========= - - SIDE (input) CHARACTER*1 - = 'L': form H * C - = 'R': form C * H - - M (input) INTEGER - The number of rows of the matrix C. - - N (input) INTEGER - The number of columns of the matrix C. - - V (input) DOUBLE PRECISION array, dimension - (1 + (M-1)*abs(INCV)) if SIDE = 'L' - or (1 + (N-1)*abs(INCV)) if SIDE = 'R' - The vector v in the representation of H. V is not used if - TAU = 0. - - INCV (input) INTEGER - The increment between elements of v. INCV <> 0. - - TAU (input) DOUBLE PRECISION - The value tau in the representation of H. - - C (input/output) DOUBLE PRECISION array, dimension (LDC,N) - On entry, the m by n matrix C. - On exit, C is overwritten by the matrix H * C if SIDE = 'L', - or C * H if SIDE = 'R'. - - LDC (input) INTEGER - The leading dimension of the array C. LDC >= max(1,M). - - WORK (workspace) DOUBLE PRECISION array, dimension - (N) if SIDE = 'L' - or (M) if SIDE = 'R' - - ===================================================================== - - - Parameter adjustments */ - /* Table of constant values */ - static doublereal c_b4 = 1.; - static doublereal c_b5 = 0.; - static integer c__1 = 1; - - /* System generated locals */ - integer c_dim1, c_offset; - doublereal d__1; - /* Local variables */ - extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *); - - - --v; - c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --work; - - /* Function Body */ - if (lsame_(side, "L")) { - -/* Form H * C */ - - if (*tau != 0.) { - -/* w := C' * v */ - - dgemv_("Transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1], incv, - &c_b5, &work[1], &c__1); - -/* C := C - v * w' */ - - d__1 = -(*tau); - dger_(m, n, &d__1, &v[1], incv, &work[1], &c__1, &c__[c_offset], - ldc); - } - } else { - -/* Form C * H */ - - if (*tau != 0.) { - -/* w := C * v */ - - dgemv_("No transpose", m, n, &c_b4, &c__[c_offset], ldc, &v[1], - incv, &c_b5, &work[1], &c__1); - -/* C := C - w * v' */ - - d__1 = -(*tau); - dger_(m, n, &d__1, &work[1], &c__1, &v[1], incv, &c__[c_offset], - ldc); - } - } - return 0; - -/* End of DLARF */ - -} /* dlarf_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlarfb.c b/ext/f2c_lapack/dlarfb.c deleted file mode 100644 index 08569ae50..000000000 --- a/ext/f2c_lapack/dlarfb.c +++ /dev/null @@ -1,711 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlarfb_(char *side, char *trans, char *direct, char * - storev, integer *m, integer *n, integer *k, doublereal *v, integer * - ldv, doublereal *t, integer *ldt, doublereal *c__, integer *ldc, - doublereal *work, integer *ldwork) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - February 29, 1992 - - - Purpose - ======= - - DLARFB applies a real block reflector H or its transpose H' to a - real m by n matrix C, from either the left or the right. - - Arguments - ========= - - SIDE (input) CHARACTER*1 - = 'L': apply H or H' from the Left - = 'R': apply H or H' from the Right - - TRANS (input) CHARACTER*1 - = 'N': apply H (No transpose) - = 'T': apply H' (Transpose) - - DIRECT (input) CHARACTER*1 - Indicates how H is formed from a product of elementary - reflectors - = 'F': H = H(1) H(2) . . . H(k) (Forward) - = 'B': H = H(k) . . . H(2) H(1) (Backward) - - STOREV (input) CHARACTER*1 - Indicates how the vectors which define the elementary - reflectors are stored: - = 'C': Columnwise - = 'R': Rowwise - - M (input) INTEGER - The number of rows of the matrix C. - - N (input) INTEGER - The number of columns of the matrix C. - - K (input) INTEGER - The order of the matrix T (= the number of elementary - reflectors whose product defines the block reflector). - - V (input) DOUBLE PRECISION array, dimension - (LDV,K) if STOREV = 'C' - (LDV,M) if STOREV = 'R' and SIDE = 'L' - (LDV,N) if STOREV = 'R' and SIDE = 'R' - The matrix V. See further details. - - LDV (input) INTEGER - The leading dimension of the array V. - If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); - if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); - if STOREV = 'R', LDV >= K. - - T (input) DOUBLE PRECISION array, dimension (LDT,K) - The triangular k by k matrix T in the representation of the - block reflector. - - LDT (input) INTEGER - The leading dimension of the array T. LDT >= K. - - C (input/output) DOUBLE PRECISION array, dimension (LDC,N) - On entry, the m by n matrix C. - On exit, C is overwritten by H*C or H'*C or C*H or C*H'. - - LDC (input) INTEGER - The leading dimension of the array C. LDA >= max(1,M). - - WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) - - LDWORK (input) INTEGER - The leading dimension of the array WORK. - If SIDE = 'L', LDWORK >= max(1,N); - if SIDE = 'R', LDWORK >= max(1,M). - - ===================================================================== - - - Quick return if possible - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static doublereal c_b14 = 1.; - static doublereal c_b25 = -1.; - - /* System generated locals */ - integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, - work_offset, i__1, i__2; - /* Local variables */ - static integer i__, j; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *); - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *), dtrmm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *); - static char transt[1]; -#define work_ref(a_1,a_2) work[(a_2)*work_dim1 + a_1] -#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] -#define v_ref(a_1,a_2) v[(a_2)*v_dim1 + a_1] - - - v_dim1 = *ldv; - v_offset = 1 + v_dim1 * 1; - v -= v_offset; - t_dim1 = *ldt; - t_offset = 1 + t_dim1 * 1; - t -= t_offset; - c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - work_dim1 = *ldwork; - work_offset = 1 + work_dim1 * 1; - work -= work_offset; - - /* Function Body */ - if (*m <= 0 || *n <= 0) { - return 0; - } - - if (lsame_(trans, "N")) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - - if (lsame_(storev, "C")) { - - if (lsame_(direct, "F")) { - -/* Let V = ( V1 ) (first K rows) - ( V2 ) - where V1 is unit lower triangular. */ - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C where C = ( C1 ) - ( C2 ) - - W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) - - W := C1' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(n, &c___ref(j, 1), ldc, &work_ref(1, j), &c__1); -/* L10: */ - } - -/* W := W * V1 */ - - dtrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14, - &v[v_offset], ldv, &work[work_offset], ldwork); - if (*m > *k) { - -/* W := W + C2'*V2 */ - - i__1 = *m - *k; - dgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, & - c___ref(*k + 1, 1), ldc, &v_ref(*k + 1, 1), ldv, & - c_b14, &work[work_offset], ldwork); - } - -/* W := W * T' or W * T */ - - dtrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[ - t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - V * W' */ - - if (*m > *k) { - -/* C2 := C2 - V2 * W' */ - - i__1 = *m - *k; - dgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, & - v_ref(*k + 1, 1), ldv, &work[work_offset], ldwork, - &c_b14, &c___ref(*k + 1, 1), ldc); - } - -/* W := W * V1' */ - - dtrmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, & - v[v_offset], ldv, &work[work_offset], ldwork); - -/* C1 := C1 - W' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(j, i__) = c___ref(j, i__) - work_ref(i__, j); -/* L20: */ - } -/* L30: */ - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' where C = ( C1 C2 ) - - W := C * V = (C1*V1 + C2*V2) (stored in WORK) - - W := C1 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(m, &c___ref(1, j), &c__1, &work_ref(1, j), &c__1); -/* L40: */ - } - -/* W := W * V1 */ - - dtrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14, - &v[v_offset], ldv, &work[work_offset], ldwork); - if (*n > *k) { - -/* W := W + C2 * V2 */ - - i__1 = *n - *k; - dgemm_("No transpose", "No transpose", m, k, &i__1, & - c_b14, &c___ref(1, *k + 1), ldc, &v_ref(*k + 1, 1) - , ldv, &c_b14, &work[work_offset], ldwork); - } - -/* W := W * T or W * T' */ - - dtrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[ - t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V' */ - - if (*n > *k) { - -/* C2 := C2 - W * V2' */ - - i__1 = *n - *k; - dgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, & - work[work_offset], ldwork, &v_ref(*k + 1, 1), ldv, - &c_b14, &c___ref(1, *k + 1), ldc); - } - -/* W := W * V1' */ - - dtrmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, & - v[v_offset], ldv, &work[work_offset], ldwork); - -/* C1 := C1 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = c___ref(i__, j) - work_ref(i__, j); -/* L50: */ - } -/* L60: */ - } - } - - } else { - -/* Let V = ( V1 ) - ( V2 ) (last K rows) - where V2 is unit upper triangular. */ - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C where C = ( C1 ) - ( C2 ) - - W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) - - W := C2' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(n, &c___ref(*m - *k + j, 1), ldc, &work_ref(1, j), - &c__1); -/* L70: */ - } - -/* W := W * V2 */ - - dtrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14, - &v_ref(*m - *k + 1, 1), ldv, &work[work_offset], - ldwork); - if (*m > *k) { - -/* W := W + C1'*V1 */ - - i__1 = *m - *k; - dgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, & - c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & - work[work_offset], ldwork); - } - -/* W := W * T' or W * T */ - - dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[ - t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - V * W' */ - - if (*m > *k) { - -/* C1 := C1 - V1 * W' */ - - i__1 = *m - *k; - dgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, & - v[v_offset], ldv, &work[work_offset], ldwork, & - c_b14, &c__[c_offset], ldc) - ; - } - -/* W := W * V2' */ - - dtrmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, & - v_ref(*m - *k + 1, 1), ldv, &work[work_offset], - ldwork); - -/* C2 := C2 - W' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(*m - *k + j, i__) = c___ref(*m - *k + j, i__) - - work_ref(i__, j); -/* L80: */ - } -/* L90: */ - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' where C = ( C1 C2 ) - - W := C * V = (C1*V1 + C2*V2) (stored in WORK) - - W := C2 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(m, &c___ref(1, *n - *k + j), &c__1, &work_ref(1, j) - , &c__1); -/* L100: */ - } - -/* W := W * V2 */ - - dtrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b14, - &v_ref(*n - *k + 1, 1), ldv, &work[work_offset], - ldwork); - if (*n > *k) { - -/* W := W + C1 * V1 */ - - i__1 = *n - *k; - dgemm_("No transpose", "No transpose", m, k, &i__1, & - c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & - c_b14, &work[work_offset], ldwork); - } - -/* W := W * T or W * T' */ - - dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[ - t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V' */ - - if (*n > *k) { - -/* C1 := C1 - W * V1' */ - - i__1 = *n - *k; - dgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, & - work[work_offset], ldwork, &v[v_offset], ldv, & - c_b14, &c__[c_offset], ldc) - ; - } - -/* W := W * V2' */ - - dtrmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, & - v_ref(*n - *k + 1, 1), ldv, &work[work_offset], - ldwork); - -/* C2 := C2 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, *n - *k + j) = c___ref(i__, *n - *k + j) - - work_ref(i__, j); -/* L110: */ - } -/* L120: */ - } - } - } - - } else if (lsame_(storev, "R")) { - - if (lsame_(direct, "F")) { - -/* Let V = ( V1 V2 ) (V1: first K columns) - where V1 is unit upper triangular. */ - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C where C = ( C1 ) - ( C2 ) - - W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) - - W := C1' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(n, &c___ref(j, 1), ldc, &work_ref(1, j), &c__1); -/* L130: */ - } - -/* W := W * V1' */ - - dtrmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, & - v[v_offset], ldv, &work[work_offset], ldwork); - if (*m > *k) { - -/* W := W + C2'*V2' */ - - i__1 = *m - *k; - dgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, & - c___ref(*k + 1, 1), ldc, &v_ref(1, *k + 1), ldv, & - c_b14, &work[work_offset], ldwork); - } - -/* W := W * T' or W * T */ - - dtrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[ - t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - V' * W' */ - - if (*m > *k) { - -/* C2 := C2 - V2' * W' */ - - i__1 = *m - *k; - dgemm_("Transpose", "Transpose", &i__1, n, k, &c_b25, & - v_ref(1, *k + 1), ldv, &work[work_offset], ldwork, - &c_b14, &c___ref(*k + 1, 1), ldc); - } - -/* W := W * V1 */ - - dtrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14, - &v[v_offset], ldv, &work[work_offset], ldwork); - -/* C1 := C1 - W' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(j, i__) = c___ref(j, i__) - work_ref(i__, j); -/* L140: */ - } -/* L150: */ - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' where C = ( C1 C2 ) - - W := C * V' = (C1*V1' + C2*V2') (stored in WORK) - - W := C1 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(m, &c___ref(1, j), &c__1, &work_ref(1, j), &c__1); -/* L160: */ - } - -/* W := W * V1' */ - - dtrmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, & - v[v_offset], ldv, &work[work_offset], ldwork); - if (*n > *k) { - -/* W := W + C2 * V2' */ - - i__1 = *n - *k; - dgemm_("No transpose", "Transpose", m, k, &i__1, &c_b14, & - c___ref(1, *k + 1), ldc, &v_ref(1, *k + 1), ldv, & - c_b14, &work[work_offset], ldwork); - } - -/* W := W * T or W * T' */ - - dtrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[ - t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V */ - - if (*n > *k) { - -/* C2 := C2 - W * V2 */ - - i__1 = *n - *k; - dgemm_("No transpose", "No transpose", m, &i__1, k, & - c_b25, &work[work_offset], ldwork, &v_ref(1, *k + - 1), ldv, &c_b14, &c___ref(1, *k + 1), ldc); - } - -/* W := W * V1 */ - - dtrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b14, - &v[v_offset], ldv, &work[work_offset], ldwork); - -/* C1 := C1 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, j) = c___ref(i__, j) - work_ref(i__, j); -/* L170: */ - } -/* L180: */ - } - - } - - } else { - -/* Let V = ( V1 V2 ) (V2: last K columns) - where V2 is unit lower triangular. */ - - if (lsame_(side, "L")) { - -/* Form H * C or H' * C where C = ( C1 ) - ( C2 ) - - W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) - - W := C2' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(n, &c___ref(*m - *k + j, 1), ldc, &work_ref(1, j), - &c__1); -/* L190: */ - } - -/* W := W * V2' */ - - dtrmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, & - v_ref(1, *m - *k + 1), ldv, &work[work_offset], - ldwork); - if (*m > *k) { - -/* W := W + C1'*V1' */ - - i__1 = *m - *k; - dgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, & - c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & - work[work_offset], ldwork); - } - -/* W := W * T' or W * T */ - - dtrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[ - t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - V' * W' */ - - if (*m > *k) { - -/* C1 := C1 - V1' * W' */ - - i__1 = *m - *k; - dgemm_("Transpose", "Transpose", &i__1, n, k, &c_b25, &v[ - v_offset], ldv, &work[work_offset], ldwork, & - c_b14, &c__[c_offset], ldc); - } - -/* W := W * V2 */ - - dtrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14, - &v_ref(1, *m - *k + 1), ldv, &work[work_offset], - ldwork); - -/* C2 := C2 - W' */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(*m - *k + j, i__) = c___ref(*m - *k + j, i__) - - work_ref(i__, j); -/* L200: */ - } -/* L210: */ - } - - } else if (lsame_(side, "R")) { - -/* Form C * H or C * H' where C = ( C1 C2 ) - - W := C * V' = (C1*V1' + C2*V2') (stored in WORK) - - W := C2 */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - dcopy_(m, &c___ref(1, *n - *k + j), &c__1, &work_ref(1, j) - , &c__1); -/* L220: */ - } - -/* W := W * V2' */ - - dtrmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, & - v_ref(1, *n - *k + 1), ldv, &work[work_offset], - ldwork); - if (*n > *k) { - -/* W := W + C1 * V1' */ - - i__1 = *n - *k; - dgemm_("No transpose", "Transpose", m, k, &i__1, &c_b14, & - c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & - work[work_offset], ldwork); - } - -/* W := W * T or W * T' */ - - dtrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[ - t_offset], ldt, &work[work_offset], ldwork); - -/* C := C - W * V */ - - if (*n > *k) { - -/* C1 := C1 - W * V1 */ - - i__1 = *n - *k; - dgemm_("No transpose", "No transpose", m, &i__1, k, & - c_b25, &work[work_offset], ldwork, &v[v_offset], - ldv, &c_b14, &c__[c_offset], ldc); - } - -/* W := W * V2 */ - - dtrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14, - &v_ref(1, *n - *k + 1), ldv, &work[work_offset], - ldwork); - -/* C1 := C1 - W */ - - i__1 = *k; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - c___ref(i__, *n - *k + j) = c___ref(i__, *n - *k + j) - - work_ref(i__, j); -/* L230: */ - } -/* L240: */ - } - - } - - } - } - - return 0; - -/* End of DLARFB */ - -} /* dlarfb_ */ - -#undef v_ref -#undef c___ref -#undef work_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlarfg.c b/ext/f2c_lapack/dlarfg.c deleted file mode 100644 index b23711f39..000000000 --- a/ext/f2c_lapack/dlarfg.c +++ /dev/null @@ -1,155 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlarfg_(integer *n, doublereal *alpha, doublereal *x, - integer *incx, doublereal *tau) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - September 30, 1994 - - - Purpose - ======= - - DLARFG generates a real elementary reflector H of order n, such - that - - H * ( alpha ) = ( beta ), H' * H = I. - ( x ) ( 0 ) - - where alpha and beta are scalars, and x is an (n-1)-element real - vector. H is represented in the form - - H = I - tau * ( 1 ) * ( 1 v' ) , - ( v ) - - where tau is a real scalar and v is a real (n-1)-element - vector. - - If the elements of x are all zero, then tau = 0 and H is taken to be - the unit matrix. - - Otherwise 1 <= tau <= 2. - - Arguments - ========= - - N (input) INTEGER - The order of the elementary reflector. - - ALPHA (input/output) DOUBLE PRECISION - On entry, the value alpha. - On exit, it is overwritten with the value beta. - - X (input/output) DOUBLE PRECISION array, dimension - (1+(N-2)*abs(INCX)) - On entry, the vector x. - On exit, it is overwritten with the vector v. - - INCX (input) INTEGER - The increment between elements of X. INCX > 0. - - TAU (output) DOUBLE PRECISION - The value tau. - - ===================================================================== - - - Parameter adjustments */ - /* System generated locals */ - integer i__1; - doublereal d__1; - /* Builtin functions */ - double d_sign(doublereal *, doublereal *); - /* Local variables */ - static doublereal beta; - extern doublereal dnrm2_(integer *, doublereal *, integer *); - static integer j; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - static doublereal xnorm; - extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *); - static doublereal safmin, rsafmn; - static integer knt; - - --x; - - /* Function Body */ - if (*n <= 1) { - *tau = 0.; - return 0; - } - - i__1 = *n - 1; - xnorm = dnrm2_(&i__1, &x[1], incx); - - if (xnorm == 0.) { - -/* H = I */ - - *tau = 0.; - } else { - -/* general case */ - - d__1 = dlapy2_(alpha, &xnorm); - beta = -d_sign(&d__1, alpha); - safmin = dlamch_("S") / dlamch_("E"); - if (abs(beta) < safmin) { - -/* XNORM, BETA may be inaccurate; scale X and recompute them */ - - rsafmn = 1. / safmin; - knt = 0; -L10: - ++knt; - i__1 = *n - 1; - dscal_(&i__1, &rsafmn, &x[1], incx); - beta *= rsafmn; - *alpha *= rsafmn; - if (abs(beta) < safmin) { - goto L10; - } - -/* New BETA is at most 1, at least SAFMIN */ - - i__1 = *n - 1; - xnorm = dnrm2_(&i__1, &x[1], incx); - d__1 = dlapy2_(alpha, &xnorm); - beta = -d_sign(&d__1, alpha); - *tau = (beta - *alpha) / beta; - i__1 = *n - 1; - d__1 = 1. / (*alpha - beta); - dscal_(&i__1, &d__1, &x[1], incx); - -/* If ALPHA is subnormal, it may lose relative accuracy */ - - *alpha = beta; - i__1 = knt; - for (j = 1; j <= i__1; ++j) { - *alpha *= safmin; -/* L20: */ - } - } else { - *tau = (beta - *alpha) / beta; - i__1 = *n - 1; - d__1 = 1. / (*alpha - beta); - dscal_(&i__1, &d__1, &x[1], incx); - *alpha = beta; - } - } - - return 0; - -/* End of DLARFG */ - -} /* dlarfg_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlarft.c b/ext/f2c_lapack/dlarft.c deleted file mode 100644 index cf4962d1e..000000000 --- a/ext/f2c_lapack/dlarft.c +++ /dev/null @@ -1,264 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlarft_(char *direct, char *storev, integer *n, integer * - k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t, - integer *ldt) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - February 29, 1992 - - - Purpose - ======= - - DLARFT forms the triangular factor T of a real block reflector H - of order n, which is defined as a product of k elementary reflectors. - - If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; - - If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. - - If STOREV = 'C', the vector which defines the elementary reflector - H(i) is stored in the i-th column of the array V, and - - H = I - V * T * V' - - If STOREV = 'R', the vector which defines the elementary reflector - H(i) is stored in the i-th row of the array V, and - - H = I - V' * T * V - - Arguments - ========= - - DIRECT (input) CHARACTER*1 - Specifies the order in which the elementary reflectors are - multiplied to form the block reflector: - = 'F': H = H(1) H(2) . . . H(k) (Forward) - = 'B': H = H(k) . . . H(2) H(1) (Backward) - - STOREV (input) CHARACTER*1 - Specifies how the vectors which define the elementary - reflectors are stored (see also Further Details): - = 'C': columnwise - = 'R': rowwise - - N (input) INTEGER - The order of the block reflector H. N >= 0. - - K (input) INTEGER - The order of the triangular factor T (= the number of - elementary reflectors). K >= 1. - - V (input/output) DOUBLE PRECISION array, dimension - (LDV,K) if STOREV = 'C' - (LDV,N) if STOREV = 'R' - The matrix V. See further details. - - LDV (input) INTEGER - The leading dimension of the array V. - If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. - - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary - reflector H(i). - - T (output) DOUBLE PRECISION array, dimension (LDT,K) - The k by k triangular factor T of the block reflector. - If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is - lower triangular. The rest of the array is not used. - - LDT (input) INTEGER - The leading dimension of the array T. LDT >= K. - - Further Details - =============== - - The shape of the matrix V and the storage of the vectors which define - the H(i) is best illustrated by the following example with n = 5 and - k = 3. The elements equal to 1 are not stored; the corresponding - array elements are modified but restored on exit. The rest of the - array is not used. - - DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': - - V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) - ( v1 1 ) ( 1 v2 v2 v2 ) - ( v1 v2 1 ) ( 1 v3 v3 ) - ( v1 v2 v3 ) - ( v1 v2 v3 ) - - DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': - - V = ( v1 v2 v3 ) V = ( v1 v1 1 ) - ( v1 v2 v3 ) ( v2 v2 v2 1 ) - ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) - ( 1 v3 ) - ( 1 ) - - ===================================================================== - - - Quick return if possible - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static doublereal c_b8 = 0.; - - /* System generated locals */ - integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3; - doublereal d__1; - /* Local variables */ - static integer i__, j; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *), dtrmv_(char *, - char *, char *, integer *, doublereal *, integer *, doublereal *, - integer *); - static doublereal vii; -#define t_ref(a_1,a_2) t[(a_2)*t_dim1 + a_1] -#define v_ref(a_1,a_2) v[(a_2)*v_dim1 + a_1] - - - v_dim1 = *ldv; - v_offset = 1 + v_dim1 * 1; - v -= v_offset; - --tau; - t_dim1 = *ldt; - t_offset = 1 + t_dim1 * 1; - t -= t_offset; - - /* Function Body */ - if (*n == 0) { - return 0; - } - - if (lsame_(direct, "F")) { - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - if (tau[i__] == 0.) { - -/* H(i) = I */ - - i__2 = i__; - for (j = 1; j <= i__2; ++j) { - t_ref(j, i__) = 0.; -/* L10: */ - } - } else { - -/* general case */ - - vii = v_ref(i__, i__); - v_ref(i__, i__) = 1.; - if (lsame_(storev, "C")) { - -/* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) */ - - i__2 = *n - i__ + 1; - i__3 = i__ - 1; - d__1 = -tau[i__]; - dgemv_("Transpose", &i__2, &i__3, &d__1, &v_ref(i__, 1), - ldv, &v_ref(i__, i__), &c__1, &c_b8, &t_ref(1, - i__), &c__1); - } else { - -/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' */ - - i__2 = i__ - 1; - i__3 = *n - i__ + 1; - d__1 = -tau[i__]; - dgemv_("No transpose", &i__2, &i__3, &d__1, &v_ref(1, i__) - , ldv, &v_ref(i__, i__), ldv, &c_b8, &t_ref(1, - i__), &c__1); - } - v_ref(i__, i__) = vii; - -/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ - - i__2 = i__ - 1; - dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[ - t_offset], ldt, &t_ref(1, i__), &c__1); - t_ref(i__, i__) = tau[i__]; - } -/* L20: */ - } - } else { - for (i__ = *k; i__ >= 1; --i__) { - if (tau[i__] == 0.) { - -/* H(i) = I */ - - i__1 = *k; - for (j = i__; j <= i__1; ++j) { - t_ref(j, i__) = 0.; -/* L30: */ - } - } else { - -/* general case */ - - if (i__ < *k) { - if (lsame_(storev, "C")) { - vii = v_ref(*n - *k + i__, i__); - v_ref(*n - *k + i__, i__) = 1.; - -/* T(i+1:k,i) := - - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) */ - - i__1 = *n - *k + i__; - i__2 = *k - i__; - d__1 = -tau[i__]; - dgemv_("Transpose", &i__1, &i__2, &d__1, &v_ref(1, - i__ + 1), ldv, &v_ref(1, i__), &c__1, &c_b8, & - t_ref(i__ + 1, i__), &c__1); - v_ref(*n - *k + i__, i__) = vii; - } else { - vii = v_ref(i__, *n - *k + i__); - v_ref(i__, *n - *k + i__) = 1.; - -/* T(i+1:k,i) := - - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' */ - - i__1 = *k - i__; - i__2 = *n - *k + i__; - d__1 = -tau[i__]; - dgemv_("No transpose", &i__1, &i__2, &d__1, &v_ref( - i__ + 1, 1), ldv, &v_ref(i__, 1), ldv, &c_b8, - &t_ref(i__ + 1, i__), &c__1); - v_ref(i__, *n - *k + i__) = vii; - } - -/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ - - i__1 = *k - i__; - dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t_ref( - i__ + 1, i__ + 1), ldt, &t_ref(i__ + 1, i__), & - c__1); - } - t_ref(i__, i__) = tau[i__]; - } -/* L40: */ - } - } - return 0; - -/* End of DLARFT */ - -} /* dlarft_ */ - -#undef v_ref -#undef t_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlartg.c b/ext/f2c_lapack/dlartg.c deleted file mode 100644 index 57df0a8d8..000000000 --- a/ext/f2c_lapack/dlartg.c +++ /dev/null @@ -1,165 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlartg_(doublereal *f, doublereal *g, doublereal *cs, - doublereal *sn, doublereal *r__) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - September 30, 1994 - - - Purpose - ======= - - DLARTG generate a plane rotation so that - - [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. - [ -SN CS ] [ G ] [ 0 ] - - This is a slower, more accurate version of the BLAS1 routine DROTG, - with the following other differences: - F and G are unchanged on return. - If G=0, then CS=1 and SN=0. - If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any - floating point operations (saves work in DBDSQR when - there are zeros on the diagonal). - - If F exceeds G in magnitude, CS will be positive. - - Arguments - ========= - - F (input) DOUBLE PRECISION - The first component of vector to be rotated. - - G (input) DOUBLE PRECISION - The second component of vector to be rotated. - - CS (output) DOUBLE PRECISION - The cosine of the rotation. - - SN (output) DOUBLE PRECISION - The sine of the rotation. - - R (output) DOUBLE PRECISION - The nonzero component of the rotated vector. - - ===================================================================== */ - /* Initialized data */ - static logical first = TRUE_; - /* System generated locals */ - integer i__1; - doublereal d__1, d__2; - /* Builtin functions */ - double log(doublereal), pow_di(doublereal *, integer *), sqrt(doublereal); - /* Local variables */ - static integer i__; - static doublereal scale; - static integer count; - static doublereal f1, g1, safmn2, safmx2; - extern doublereal dlamch_(char *); - static doublereal safmin, eps; - - - - if (first) { - first = FALSE_; - safmin = dlamch_("S"); - eps = dlamch_("E"); - d__1 = dlamch_("B"); - i__1 = (integer) (log(safmin / eps) / log(dlamch_("B")) / - 2.); - safmn2 = pow_di(&d__1, &i__1); - safmx2 = 1. / safmn2; - } - if (*g == 0.) { - *cs = 1.; - *sn = 0.; - *r__ = *f; - } else if (*f == 0.) { - *cs = 0.; - *sn = 1.; - *r__ = *g; - } else { - f1 = *f; - g1 = *g; -/* Computing MAX */ - d__1 = abs(f1), d__2 = abs(g1); - scale = max(d__1,d__2); - if (scale >= safmx2) { - count = 0; -L10: - ++count; - f1 *= safmn2; - g1 *= safmn2; -/* Computing MAX */ - d__1 = abs(f1), d__2 = abs(g1); - scale = max(d__1,d__2); - if (scale >= safmx2) { - goto L10; - } -/* Computing 2nd power */ - d__1 = f1; -/* Computing 2nd power */ - d__2 = g1; - *r__ = sqrt(d__1 * d__1 + d__2 * d__2); - *cs = f1 / *r__; - *sn = g1 / *r__; - i__1 = count; - for (i__ = 1; i__ <= i__1; ++i__) { - *r__ *= safmx2; -/* L20: */ - } - } else if (scale <= safmn2) { - count = 0; -L30: - ++count; - f1 *= safmx2; - g1 *= safmx2; -/* Computing MAX */ - d__1 = abs(f1), d__2 = abs(g1); - scale = max(d__1,d__2); - if (scale <= safmn2) { - goto L30; - } -/* Computing 2nd power */ - d__1 = f1; -/* Computing 2nd power */ - d__2 = g1; - *r__ = sqrt(d__1 * d__1 + d__2 * d__2); - *cs = f1 / *r__; - *sn = g1 / *r__; - i__1 = count; - for (i__ = 1; i__ <= i__1; ++i__) { - *r__ *= safmn2; -/* L40: */ - } - } else { -/* Computing 2nd power */ - d__1 = f1; -/* Computing 2nd power */ - d__2 = g1; - *r__ = sqrt(d__1 * d__1 + d__2 * d__2); - *cs = f1 / *r__; - *sn = g1 / *r__; - } - if (abs(*f) > abs(*g) && *cs < 0.) { - *cs = -(*cs); - *sn = -(*sn); - *r__ = -(*r__); - } - } - return 0; - -/* End of DLARTG */ - -} /* dlartg_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlas2.c b/ext/f2c_lapack/dlas2.c deleted file mode 100644 index 5298fedad..000000000 --- a/ext/f2c_lapack/dlas2.c +++ /dev/null @@ -1,128 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlas2_(doublereal *f, doublereal *g, doublereal *h__, - doublereal *ssmin, doublereal *ssmax) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - September 30, 1994 - - - Purpose - ======= - - DLAS2 computes the singular values of the 2-by-2 matrix - [ F G ] - [ 0 H ]. - On return, SSMIN is the smaller singular value and SSMAX is the - larger singular value. - - Arguments - ========= - - F (input) DOUBLE PRECISION - The (1,1) element of the 2-by-2 matrix. - - G (input) DOUBLE PRECISION - The (1,2) element of the 2-by-2 matrix. - - H (input) DOUBLE PRECISION - The (2,2) element of the 2-by-2 matrix. - - SSMIN (output) DOUBLE PRECISION - The smaller singular value. - - SSMAX (output) DOUBLE PRECISION - The larger singular value. - - Further Details - =============== - - Barring over/underflow, all output quantities are correct to within - a few units in the last place (ulps), even in the absence of a guard - digit in addition/subtraction. - - In IEEE arithmetic, the code works correctly if one matrix element is - infinite. - - Overflow will not occur unless the largest singular value itself - overflows, or is within a few ulps of overflow. (On machines with - partial overflow, like the Cray, overflow may occur if the largest - singular value is within a factor of 2 of overflow.) - - Underflow is harmless if underflow is gradual. Otherwise, results - may correspond to a matrix modified by perturbations of size near - the underflow threshold. - - ==================================================================== */ - /* System generated locals */ - doublereal d__1, d__2; - /* Builtin functions */ - double sqrt(doublereal); - /* Local variables */ - static doublereal fhmn, fhmx, c__, fa, ga, ha, as, at, au; - - - - fa = abs(*f); - ga = abs(*g); - ha = abs(*h__); - fhmn = min(fa,ha); - fhmx = max(fa,ha); - if (fhmn == 0.) { - *ssmin = 0.; - if (fhmx == 0.) { - *ssmax = ga; - } else { -/* Computing 2nd power */ - d__1 = min(fhmx,ga) / max(fhmx,ga); - *ssmax = max(fhmx,ga) * sqrt(d__1 * d__1 + 1.); - } - } else { - if (ga < fhmx) { - as = fhmn / fhmx + 1.; - at = (fhmx - fhmn) / fhmx; -/* Computing 2nd power */ - d__1 = ga / fhmx; - au = d__1 * d__1; - c__ = 2. / (sqrt(as * as + au) + sqrt(at * at + au)); - *ssmin = fhmn * c__; - *ssmax = fhmx / c__; - } else { - au = fhmx / ga; - if (au == 0.) { - -/* Avoid possible harmful underflow if exponent range - asymmetric (true SSMIN may not underflow even if - AU underflows) */ - - *ssmin = fhmn * fhmx / ga; - *ssmax = ga; - } else { - as = fhmn / fhmx + 1.; - at = (fhmx - fhmn) / fhmx; -/* Computing 2nd power */ - d__1 = as * au; -/* Computing 2nd power */ - d__2 = at * au; - c__ = 1. / (sqrt(d__1 * d__1 + 1.) + sqrt(d__2 * d__2 + 1.)); - *ssmin = fhmn * c__ * au; - *ssmin += *ssmin; - *ssmax = ga / (c__ + c__); - } - } - } - return 0; - -/* End of DLAS2 */ - -} /* dlas2_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlascl.c b/ext/f2c_lapack/dlascl.c deleted file mode 100644 index fb97f3009..000000000 --- a/ext/f2c_lapack/dlascl.c +++ /dev/null @@ -1,319 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlascl_(char *type__, integer *kl, integer *ku, - doublereal *cfrom, doublereal *cto, integer *m, integer *n, - doublereal *a, integer *lda, integer *info) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - February 29, 1992 - - - Purpose - ======= - - DLASCL multiplies the M by N real matrix A by the real scalar - CTO/CFROM. This is done without over/underflow as long as the final - result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that - A may be full, upper triangular, lower triangular, upper Hessenberg, - or banded. - - Arguments - ========= - - TYPE (input) CHARACTER*1 - TYPE indices the storage type of the input matrix. - = 'G': A is a full matrix. - = 'L': A is a lower triangular matrix. - = 'U': A is an upper triangular matrix. - = 'H': A is an upper Hessenberg matrix. - = 'B': A is a symmetric band matrix with lower bandwidth KL - and upper bandwidth KU and with the only the lower - half stored. - = 'Q': A is a symmetric band matrix with lower bandwidth KL - and upper bandwidth KU and with the only the upper - half stored. - = 'Z': A is a band matrix with lower bandwidth KL and upper - bandwidth KU. - - KL (input) INTEGER - The lower bandwidth of A. Referenced only if TYPE = 'B', - 'Q' or 'Z'. - - KU (input) INTEGER - The upper bandwidth of A. Referenced only if TYPE = 'B', - 'Q' or 'Z'. - - CFROM (input) DOUBLE PRECISION - CTO (input) DOUBLE PRECISION - The matrix A is multiplied by CTO/CFROM. A(I,J) is computed - without over/underflow if the final result CTO*A(I,J)/CFROM - can be represented without over/underflow. CFROM must be - nonzero. - - M (input) INTEGER - The number of rows of the matrix A. M >= 0. - - N (input) INTEGER - The number of columns of the matrix A. N >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,M) - The matrix to be multiplied by CTO/CFROM. See TYPE for the - storage type. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - INFO (output) INTEGER - 0 - successful exit - <0 - if INFO = -i, the i-th argument had an illegal value. - - ===================================================================== - - - Test the input arguments - - Parameter adjustments */ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; - /* Local variables */ - static logical done; - static doublereal ctoc; - static integer i__, j; - extern logical lsame_(char *, char *); - static integer itype, k1, k2, k3, k4; - static doublereal cfrom1; - extern doublereal dlamch_(char *); - static doublereal cfromc; - extern /* Subroutine */ int xerbla_(char *, integer *); - static doublereal bignum, smlnum, mul, cto1; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ - *info = 0; - - if (lsame_(type__, "G")) { - itype = 0; - } else if (lsame_(type__, "L")) { - itype = 1; - } else if (lsame_(type__, "U")) { - itype = 2; - } else if (lsame_(type__, "H")) { - itype = 3; - } else if (lsame_(type__, "B")) { - itype = 4; - } else if (lsame_(type__, "Q")) { - itype = 5; - } else if (lsame_(type__, "Z")) { - itype = 6; - } else { - itype = -1; - } - - if (itype == -1) { - *info = -1; - } else if (*cfrom == 0.) { - *info = -4; - } else if (*m < 0) { - *info = -6; - } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) { - *info = -7; - } else if (itype <= 3 && *lda < max(1,*m)) { - *info = -9; - } else if (itype >= 4) { -/* Computing MAX */ - i__1 = *m - 1; - if (*kl < 0 || *kl > max(i__1,0)) { - *info = -2; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = *n - 1; - if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) && - *kl != *ku) { - *info = -3; - } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < * - ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) { - *info = -9; - } - } - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLASCL", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *m == 0) { - return 0; - } - -/* Get machine parameters */ - - smlnum = dlamch_("S"); - bignum = 1. / smlnum; - - cfromc = *cfrom; - ctoc = *cto; - -L10: - cfrom1 = cfromc * smlnum; - cto1 = ctoc / bignum; - if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) { - mul = smlnum; - done = FALSE_; - cfromc = cfrom1; - } else if (abs(cto1) > abs(cfromc)) { - mul = bignum; - done = FALSE_; - ctoc = cto1; - } else { - mul = ctoc / cfromc; - done = TRUE_; - } - - if (itype == 0) { - -/* Full matrix */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - a_ref(i__, j) = a_ref(i__, j) * mul; -/* L20: */ - } -/* L30: */ - } - - } else if (itype == 1) { - -/* Lower triangular matrix */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { - a_ref(i__, j) = a_ref(i__, j) * mul; -/* L40: */ - } -/* L50: */ - } - - } else if (itype == 2) { - -/* Upper triangular matrix */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = min(j,*m); - for (i__ = 1; i__ <= i__2; ++i__) { - a_ref(i__, j) = a_ref(i__, j) * mul; -/* L60: */ - } -/* L70: */ - } - - } else if (itype == 3) { - -/* Upper Hessenberg matrix */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = j + 1; - i__2 = min(i__3,*m); - for (i__ = 1; i__ <= i__2; ++i__) { - a_ref(i__, j) = a_ref(i__, j) * mul; -/* L80: */ - } -/* L90: */ - } - - } else if (itype == 4) { - -/* Lower half of a symmetric band matrix */ - - k3 = *kl + 1; - k4 = *n + 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = k3, i__4 = k4 - j; - i__2 = min(i__3,i__4); - for (i__ = 1; i__ <= i__2; ++i__) { - a_ref(i__, j) = a_ref(i__, j) * mul; -/* L100: */ - } -/* L110: */ - } - - } else if (itype == 5) { - -/* Upper half of a symmetric band matrix */ - - k1 = *ku + 2; - k3 = *ku + 1; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__2 = k1 - j; - i__3 = k3; - for (i__ = max(i__2,1); i__ <= i__3; ++i__) { - a_ref(i__, j) = a_ref(i__, j) * mul; -/* L120: */ - } -/* L130: */ - } - - } else if (itype == 6) { - -/* Band matrix */ - - k1 = *kl + *ku + 2; - k2 = *kl + 1; - k3 = (*kl << 1) + *ku + 1; - k4 = *kl + *ku + 1 + *m; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - i__3 = k1 - j; -/* Computing MIN */ - i__4 = k3, i__5 = k4 - j; - i__2 = min(i__4,i__5); - for (i__ = max(i__3,k2); i__ <= i__2; ++i__) { - a_ref(i__, j) = a_ref(i__, j) * mul; -/* L140: */ - } -/* L150: */ - } - - } - - if (! done) { - goto L10; - } - - return 0; - -/* End of DLASCL */ - -} /* dlascl_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlaset.c b/ext/f2c_lapack/dlaset.c deleted file mode 100644 index 6c16b51f8..000000000 --- a/ext/f2c_lapack/dlaset.c +++ /dev/null @@ -1,139 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlaset_(char *uplo, integer *m, integer *n, doublereal * - alpha, doublereal *beta, doublereal *a, integer *lda) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1992 - - - Purpose - ======= - - DLASET initializes an m-by-n matrix A to BETA on the diagonal and - ALPHA on the offdiagonals. - - Arguments - ========= - - UPLO (input) CHARACTER*1 - Specifies the part of the matrix A to be set. - = 'U': Upper triangular part is set; the strictly lower - triangular part of A is not changed. - = 'L': Lower triangular part is set; the strictly upper - triangular part of A is not changed. - Otherwise: All of the matrix A is set. - - M (input) INTEGER - The number of rows of the matrix A. M >= 0. - - N (input) INTEGER - The number of columns of the matrix A. N >= 0. - - ALPHA (input) DOUBLE PRECISION - The constant to which the offdiagonal elements are to be set. - - BETA (input) DOUBLE PRECISION - The constant to which the diagonal elements are to be set. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On exit, the leading m-by-n submatrix of A is set as follows: - - if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, - if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, - otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, - - and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - ===================================================================== - - - Parameter adjustments */ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - /* Local variables */ - static integer i__, j; - extern logical lsame_(char *, char *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ - if (lsame_(uplo, "U")) { - -/* Set the strictly upper triangular or trapezoidal part of the - array to ALPHA. */ - - i__1 = *n; - for (j = 2; j <= i__1; ++j) { -/* Computing MIN */ - i__3 = j - 1; - i__2 = min(i__3,*m); - for (i__ = 1; i__ <= i__2; ++i__) { - a_ref(i__, j) = *alpha; -/* L10: */ - } -/* L20: */ - } - - } else if (lsame_(uplo, "L")) { - -/* Set the strictly lower triangular or trapezoidal part of the - array to ALPHA. */ - - i__1 = min(*m,*n); - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = j + 1; i__ <= i__2; ++i__) { - a_ref(i__, j) = *alpha; -/* L30: */ - } -/* L40: */ - } - - } else { - -/* Set the leading m-by-n submatrix to ALPHA. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - a_ref(i__, j) = *alpha; -/* L50: */ - } -/* L60: */ - } - } - -/* Set the first min(M,N) diagonal elements to BETA. */ - - i__1 = min(*m,*n); - for (i__ = 1; i__ <= i__1; ++i__) { - a_ref(i__, i__) = *beta; -/* L70: */ - } - - return 0; - -/* End of DLASET */ - -} /* dlaset_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlasq1.c b/ext/f2c_lapack/dlasq1.c deleted file mode 100644 index 9f63e4aa1..000000000 --- a/ext/f2c_lapack/dlasq1.c +++ /dev/null @@ -1,199 +0,0 @@ -#include "blaswrap.h" -/* -- translated by f2c (version 19990503). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__2 = 2; -static integer c__0 = 0; - -/* Subroutine */ int dlasq1_(integer *n, doublereal *d__, doublereal *e, - doublereal *work, integer *info) -{ - /* System generated locals */ - integer i__1, i__2; - doublereal d__1, d__2, d__3; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal - *, doublereal *, doublereal *); - static integer i__; - static doublereal scale; - static integer iinfo; - static doublereal sigmn; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); - static doublereal sigmx; - extern /* Subroutine */ int dlasq2_(integer *, doublereal *, integer *); - extern doublereal dlamch_(char *); - extern /* Subroutine */ int dlascl_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, integer *); - static doublereal safmin; - extern /* Subroutine */ int xerbla_(char *, integer *), dlasrt_( - char *, integer *, doublereal *, integer *); - static doublereal eps; - - -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1999 - - - Purpose - ======= - - DLASQ1 computes the singular values of a real N-by-N bidiagonal - matrix with diagonal D and off-diagonal E. The singular values - are computed to high relative accuracy, in the absence of - denormalization, underflow and overflow. The algorithm was first - presented in - - "Accurate singular values and differential qd algorithms" by K. V. - Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230, - 1994, - - and the present implementation is described in "An implementation of - the dqds Algorithm (Positive Case)", LAPACK Working Note. - - Arguments - ========= - - N (input) INTEGER - The number of rows and columns in the matrix. N >= 0. - - D (input/output) DOUBLE PRECISION array, dimension (N) - On entry, D contains the diagonal elements of the - bidiagonal matrix whose SVD is desired. On normal exit, - D contains the singular values in decreasing order. - - E (input/output) DOUBLE PRECISION array, dimension (N) - On entry, elements E(1:N-1) contain the off-diagonal elements - of the bidiagonal matrix whose SVD is desired. - On exit, E is overwritten. - - WORK (workspace) DOUBLE PRECISION array, dimension (4*N) - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - > 0: the algorithm failed - = 1, a split was marked by a positive value in E - = 2, current block of Z not diagonalized after 30*N - iterations (in inner while loop) - = 3, termination criterion of outer while loop not met - (program created more than N unreduced blocks) - - ===================================================================== - - - Parameter adjustments */ - --work; - --e; - --d__; - - /* Function Body */ - *info = 0; - if (*n < 0) { - *info = -2; - i__1 = -(*info); - xerbla_("DLASQ1", &i__1); - return 0; - } else if (*n == 0) { - return 0; - } else if (*n == 1) { - d__[1] = abs(d__[1]); - return 0; - } else if (*n == 2) { - dlas2_(&d__[1], &e[1], &d__[2], &sigmn, &sigmx); - d__[1] = sigmx; - d__[2] = sigmn; - return 0; - } - -/* Estimate the largest singular value. */ - - sigmx = 0.; - i__1 = *n - 1; - for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = (d__1 = d__[i__], abs(d__1)); -/* Computing MAX */ - d__2 = sigmx, d__3 = (d__1 = e[i__], abs(d__1)); - sigmx = max(d__2,d__3); -/* L10: */ - } - d__[*n] = (d__1 = d__[*n], abs(d__1)); - -/* Early return if SIGMX is zero (matrix is already diagonal). */ - - if (sigmx == 0.) { - dlasrt_("D", n, &d__[1], &iinfo); - return 0; - } - - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__1 = sigmx, d__2 = d__[i__]; - sigmx = max(d__1,d__2); -/* L20: */ - } - -/* Copy D and E into WORK (in the Z format) and scale (squaring the - input data makes scaling by a power of the radix pointless). */ - - eps = dlamch_("Precision"); - safmin = dlamch_("Safe minimum"); - scale = sqrt(eps / safmin); - dcopy_(n, &d__[1], &c__1, &work[1], &c__2); - i__1 = *n - 1; - dcopy_(&i__1, &e[1], &c__1, &work[2], &c__2); - i__1 = (*n << 1) - 1; - i__2 = (*n << 1) - 1; - dlascl_("G", &c__0, &c__0, &sigmx, &scale, &i__1, &c__1, &work[1], &i__2, - &iinfo); - -/* Compute the q's and e's. */ - - i__1 = (*n << 1) - 1; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing 2nd power */ - d__1 = work[i__]; - work[i__] = d__1 * d__1; -/* L30: */ - } - work[*n * 2] = 0.; - - dlasq2_(n, &work[1], info); - - if (*info == 0) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - d__[i__] = sqrt(work[i__]); -/* L40: */ - } - dlascl_("G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, & - iinfo); - } - - return 0; - -/* End of DLASQ1 */ - -} /* dlasq1_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlasq2.c b/ext/f2c_lapack/dlasq2.c deleted file mode 100644 index f939bdfb4..000000000 --- a/ext/f2c_lapack/dlasq2.c +++ /dev/null @@ -1,529 +0,0 @@ -#include "blaswrap.h" -/* -- translated by f2c (version 19990503). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__2 = 2; -static integer c__10 = 10; -static integer c__3 = 3; -static integer c__4 = 4; -static integer c__11 = 11; - -/* Subroutine */ int dlasq2_(integer *n, doublereal *z__, integer *info) -{ - /* System generated locals */ - integer i__1, i__2, i__3; - doublereal d__1, d__2; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - static logical ieee; - static integer nbig; - static doublereal dmin__, emin, emax; - static integer ndiv, iter; - static doublereal qmin, temp, qmax, zmax; - static integer splt; - static doublereal d__, e; - static integer k; - static doublereal s, t; - static integer nfail; - static doublereal desig, trace, sigma; - static integer iinfo, i0, i4, n0; - extern /* Subroutine */ int dlasq3_(integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, doublereal *, doublereal *, - integer *, integer *, integer *, logical *); - extern doublereal dlamch_(char *); - static integer pp, iwhila, iwhilb; - static doublereal oldemn, safmin; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int dlasrt_(char *, integer *, doublereal *, - integer *); - static doublereal eps, tol; - static integer ipn4; - static doublereal tol2; - - -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1999 - - - Purpose - ======= - - DLASQ2 computes all the eigenvalues of the symmetric positive - definite tridiagonal matrix associated with the qd array Z to high - relative accuracy are computed to high relative accuracy, in the - absence of denormalization, underflow and overflow. - - To see the relation of Z to the tridiagonal matrix, let L be a - unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and - let U be an upper bidiagonal matrix with 1's above and diagonal - Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the - symmetric tridiagonal to which it is similar. - - Note : DLASQ2 defines a logical variable, IEEE, which is true - on machines which follow ieee-754 floating-point standard in their - handling of infinities and NaNs, and false otherwise. This variable - is passed to DLASQ3. - - Arguments - ========= - - N (input) INTEGER - The number of rows and columns in the matrix. N >= 0. - - Z (workspace) DOUBLE PRECISION array, dimension ( 4*N ) - On entry Z holds the qd array. On exit, entries 1 to N hold - the eigenvalues in decreasing order, Z( 2*N+1 ) holds the - trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If - N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 ) - holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of - shifts that failed. - - INFO (output) INTEGER - = 0: successful exit - < 0: if the i-th argument is a scalar and had an illegal - value, then INFO = -i, if the i-th argument is an - array and the j-entry had an illegal value, then - INFO = -(i*100+j) - > 0: the algorithm failed - = 1, a split was marked by a positive value in E - = 2, current block of Z not diagonalized after 30*N - iterations (in inner while loop) - = 3, termination criterion of outer while loop not met - (program created more than N unreduced blocks) - - Further Details - =============== - Local Variables: I0:N0 defines a current unreduced segment of Z. - The shifts are accumulated in SIGMA. Iteration count is in ITER. - Ping-pong is controlled by PP (alternates between 0 and 1). - - ===================================================================== - - - Test the input arguments. - (in case DLASQ2 is not called by DLASQ1) - - Parameter adjustments */ - --z__; - - /* Function Body */ - *info = 0; - eps = dlamch_("Precision"); - safmin = dlamch_("Safe minimum"); - tol = eps * 100.; -/* Computing 2nd power */ - d__1 = tol; - tol2 = d__1 * d__1; - - if (*n < 0) { - *info = -1; - xerbla_("DLASQ2", &c__1); - return 0; - } else if (*n == 0) { - return 0; - } else if (*n == 1) { - -/* 1-by-1 case. */ - - if (z__[1] < 0.) { - *info = -201; - xerbla_("DLASQ2", &c__2); - } - return 0; - } else if (*n == 2) { - -/* 2-by-2 case. */ - - if (z__[2] < 0. || z__[3] < 0.) { - *info = -2; - xerbla_("DLASQ2", &c__2); - return 0; - } else if (z__[3] > z__[1]) { - d__ = z__[3]; - z__[3] = z__[1]; - z__[1] = d__; - } - z__[5] = z__[1] + z__[2] + z__[3]; - if (z__[2] > z__[3] * tol2) { - t = (z__[1] - z__[3] + z__[2]) * .5; - s = z__[3] * (z__[2] / t); - if (s <= t) { - s = z__[3] * (z__[2] / (t * (sqrt(s / t + 1.) + 1.))); - } else { - s = z__[3] * (z__[2] / (t + sqrt(t) * sqrt(t + s))); - } - t = z__[1] + (s + z__[2]); - z__[3] *= z__[1] / t; - z__[1] = t; - } - z__[2] = z__[3]; - z__[6] = z__[2] + z__[1]; - return 0; - } - -/* Check for negative data and compute sums of q's and e's. */ - - z__[*n * 2] = 0.; - emin = z__[2]; - qmax = 0.; - zmax = 0.; - d__ = 0.; - e = 0.; - - i__1 = (*n - 1) << 1; - for (k = 1; k <= i__1; k += 2) { - if (z__[k] < 0.) { - *info = -(k + 200); - xerbla_("DLASQ2", &c__2); - return 0; - } else if (z__[k + 1] < 0.) { - *info = -(k + 201); - xerbla_("DLASQ2", &c__2); - return 0; - } - d__ += z__[k]; - e += z__[k + 1]; -/* Computing MAX */ - d__1 = qmax, d__2 = z__[k]; - qmax = max(d__1,d__2); -/* Computing MIN */ - d__1 = emin, d__2 = z__[k + 1]; - emin = min(d__1,d__2); -/* Computing MAX */ - d__1 = max(qmax,zmax), d__2 = z__[k + 1]; - zmax = max(d__1,d__2); -/* L10: */ - } - if (z__[(*n << 1) - 1] < 0.) { - *info = -((*n << 1) + 199); - xerbla_("DLASQ2", &c__2); - return 0; - } - d__ += z__[(*n << 1) - 1]; -/* Computing MAX */ - d__1 = qmax, d__2 = z__[(*n << 1) - 1]; - qmax = max(d__1,d__2); - zmax = max(qmax,zmax); - -/* Check for diagonality. */ - - if (e == 0.) { - i__1 = *n; - for (k = 2; k <= i__1; ++k) { - z__[k] = z__[(k << 1) - 1]; -/* L20: */ - } - dlasrt_("D", n, &z__[1], &iinfo); - z__[(*n << 1) - 1] = d__; - return 0; - } - - trace = d__ + e; - -/* Check for zero data. */ - - if (trace == 0.) { - z__[(*n << 1) - 1] = 0.; - return 0; - } - -/* Check whether the machine is IEEE conformable. */ - - ieee = ilaenv_(&c__10, "DLASQ2", "N", &c__1, &c__2, &c__3, &c__4, (ftnlen) - 6, (ftnlen)1) == 1 && ilaenv_(&c__11, "DLASQ2", "N", &c__1, &c__2, - &c__3, &c__4, (ftnlen)6, (ftnlen)1) == 1; - -/* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). */ - - for (k = *n << 1; k >= 2; k += -2) { - z__[k * 2] = 0.; - z__[(k << 1) - 1] = z__[k]; - z__[(k << 1) - 2] = 0.; - z__[(k << 1) - 3] = z__[k - 1]; -/* L30: */ - } - - i0 = 1; - n0 = *n; - -/* Reverse the qd-array, if warranted. */ - - if (z__[(i0 << 2) - 3] * 1.5 < z__[(n0 << 2) - 3]) { - ipn4 = (i0 + n0) << 2; - i__1 = (i0 + n0 - 1) << 1; - for (i4 = i0 << 2; i4 <= i__1; i4 += 4) { - temp = z__[i4 - 3]; - z__[i4 - 3] = z__[ipn4 - i4 - 3]; - z__[ipn4 - i4 - 3] = temp; - temp = z__[i4 - 1]; - z__[i4 - 1] = z__[ipn4 - i4 - 5]; - z__[ipn4 - i4 - 5] = temp; -/* L40: */ - } - } - -/* Initial split checking via dqd and Li's test. */ - - pp = 0; - - for (k = 1; k <= 2; ++k) { - - d__ = z__[(n0 << 2) + pp - 3]; - i__1 = (i0 << 2) + pp; - for (i4 = ((n0 - 1) << 2) + pp; i4 >= i__1; i4 += -4) { - if (z__[i4 - 1] <= tol2 * d__) { - z__[i4 - 1] = 0.; - d__ = z__[i4 - 3]; - } else { - d__ = z__[i4 - 3] * (d__ / (d__ + z__[i4 - 1])); - } -/* L50: */ - } - -/* dqd maps Z to ZZ plus Li's test. */ - - emin = z__[(i0 << 2) + pp + 1]; - d__ = z__[(i0 << 2) + pp - 3]; - i__1 = ((n0 - 1) << 2) + pp; - for (i4 = (i0 << 2) + pp; i4 <= i__1; i4 += 4) { - z__[i4 - (pp << 1) - 2] = d__ + z__[i4 - 1]; - if (z__[i4 - 1] <= tol2 * d__) { - z__[i4 - 1] = 0.; - z__[i4 - (pp << 1) - 2] = d__; - z__[i4 - (pp << 1)] = 0.; - d__ = z__[i4 + 1]; - } else if (safmin * z__[i4 + 1] < z__[i4 - (pp << 1) - 2] && - safmin * z__[i4 - (pp << 1) - 2] < z__[i4 + 1]) { - temp = z__[i4 + 1] / z__[i4 - (pp << 1) - 2]; - z__[i4 - (pp << 1)] = z__[i4 - 1] * temp; - d__ *= temp; - } else { - z__[i4 - (pp << 1)] = z__[i4 + 1] * (z__[i4 - 1] / z__[i4 - ( - pp << 1) - 2]); - d__ = z__[i4 + 1] * (d__ / z__[i4 - (pp << 1) - 2]); - } -/* Computing MIN */ - d__1 = emin, d__2 = z__[i4 - (pp << 1)]; - emin = min(d__1,d__2); -/* L60: */ - } - z__[(n0 << 2) - pp - 2] = d__; - -/* Now find qmax. */ - - qmax = z__[(i0 << 2) - pp - 2]; - i__1 = (n0 << 2) - pp - 2; - for (i4 = (i0 << 2) - pp + 2; i4 <= i__1; i4 += 4) { -/* Computing MAX */ - d__1 = qmax, d__2 = z__[i4]; - qmax = max(d__1,d__2); -/* L70: */ - } - -/* Prepare for the next iteration on K. */ - - pp = 1 - pp; -/* L80: */ - } - - iter = 2; - nfail = 0; - ndiv = (n0 - i0) << 1; - - i__1 = *n + 1; - for (iwhila = 1; iwhila <= i__1; ++iwhila) { - if (n0 < 1) { - goto L150; - } - -/* While array unfinished do - - E(N0) holds the value of SIGMA when submatrix in I0:N0 - splits from the rest of the array, but is negated. */ - - desig = 0.; - if (n0 == *n) { - sigma = 0.; - } else { - sigma = -z__[(n0 << 2) - 1]; - } - if (sigma < 0.) { - *info = 1; - return 0; - } - -/* Find last unreduced submatrix's top index I0, find QMAX and - EMIN. Find Gershgorin-type bound if Q's much greater than E's. */ - - emax = 0.; - if (n0 > i0) { - emin = (d__1 = z__[(n0 << 2) - 5], abs(d__1)); - } else { - emin = 0.; - } - qmin = z__[(n0 << 2) - 3]; - qmax = qmin; - for (i4 = n0 << 2; i4 >= 8; i4 += -4) { - if (z__[i4 - 5] <= 0.) { - goto L100; - } - if (qmin >= emax * 4.) { -/* Computing MIN */ - d__1 = qmin, d__2 = z__[i4 - 3]; - qmin = min(d__1,d__2); -/* Computing MAX */ - d__1 = emax, d__2 = z__[i4 - 5]; - emax = max(d__1,d__2); - } -/* Computing MAX */ - d__1 = qmax, d__2 = z__[i4 - 7] + z__[i4 - 5]; - qmax = max(d__1,d__2); -/* Computing MIN */ - d__1 = emin, d__2 = z__[i4 - 5]; - emin = min(d__1,d__2); -/* L90: */ - } - i4 = 4; - -L100: - i0 = i4 / 4; - -/* Store EMIN for passing to DLASQ3. */ - - z__[(n0 << 2) - 1] = emin; - -/* Put -(initial shift) into DMIN. - - Computing MAX */ - d__1 = 0., d__2 = qmin - sqrt(qmin) * 2. * sqrt(emax); - dmin__ = -max(d__1,d__2); - -/* Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong. */ - - pp = 0; - - nbig = (n0 - i0 + 1) * 30; - i__2 = nbig; - for (iwhilb = 1; iwhilb <= i__2; ++iwhilb) { - if (i0 > n0) { - goto L130; - } - -/* While submatrix unfinished take a good dqds step. */ - - dlasq3_(&i0, &n0, &z__[1], &pp, &dmin__, &sigma, &desig, &qmax, & - nfail, &iter, &ndiv, &ieee); - - pp = 1 - pp; - -/* When EMIN is very small check for splits. */ - - if (pp == 0 && n0 - i0 >= 3) { - if (z__[n0 * 4] <= tol2 * qmax || z__[(n0 << 2) - 1] <= tol2 * - sigma) { - splt = i0 - 1; - qmax = z__[(i0 << 2) - 3]; - emin = z__[(i0 << 2) - 1]; - oldemn = z__[i0 * 4]; - i__3 = (n0 - 3) << 2; - for (i4 = i0 << 2; i4 <= i__3; i4 += 4) { - if (z__[i4] <= tol2 * z__[i4 - 3] || z__[i4 - 1] <= - tol2 * sigma) { - z__[i4 - 1] = -sigma; - splt = i4 / 4; - qmax = 0.; - emin = z__[i4 + 3]; - oldemn = z__[i4 + 4]; - } else { -/* Computing MAX */ - d__1 = qmax, d__2 = z__[i4 + 1]; - qmax = max(d__1,d__2); -/* Computing MIN */ - d__1 = emin, d__2 = z__[i4 - 1]; - emin = min(d__1,d__2); -/* Computing MIN */ - d__1 = oldemn, d__2 = z__[i4]; - oldemn = min(d__1,d__2); - } -/* L110: */ - } - z__[(n0 << 2) - 1] = emin; - z__[n0 * 4] = oldemn; - i0 = splt + 1; - } - } - -/* L120: */ - } - - *info = 2; - return 0; - -/* end IWHILB */ - -L130: - -/* L140: */ - ; - } - - *info = 3; - return 0; - -/* end IWHILA */ - -L150: - -/* Move q's to the front. */ - - i__1 = *n; - for (k = 2; k <= i__1; ++k) { - z__[k] = z__[(k << 2) - 3]; -/* L160: */ - } - -/* Sort and compute sum of eigenvalues. */ - - dlasrt_("D", n, &z__[1], &iinfo); - - e = 0.; - for (k = *n; k >= 1; --k) { - e += z__[k]; -/* L170: */ - } - -/* Store trace, sum(eigenvalues) and information on performance. */ - - z__[(*n << 1) + 1] = trace; - z__[(*n << 1) + 2] = e; - z__[(*n << 1) + 3] = (doublereal) iter; -/* Computing 2nd power */ - i__1 = *n; - z__[(*n << 1) + 4] = (doublereal) ndiv / (doublereal) (i__1 * i__1); - z__[(*n << 1) + 5] = nfail * 100. / (doublereal) iter; - return 0; - -/* End of DLASQ2 */ - -} /* dlasq2_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlasq3.c b/ext/f2c_lapack/dlasq3.c deleted file mode 100644 index a1934a9b5..000000000 --- a/ext/f2c_lapack/dlasq3.c +++ /dev/null @@ -1,323 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlasq3_(integer *i0, integer *n0, doublereal *z__, - integer *pp, doublereal *dmin__, doublereal *sigma, doublereal *desig, - doublereal *qmax, integer *nfail, integer *iter, integer *ndiv, - logical *ieee) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - May 17, 2000 - - - Purpose - ======= - - DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. - In case of failure it changes shifts, and tries again until output - is positive. - - Arguments - ========= - - I0 (input) INTEGER - First index. - - N0 (input) INTEGER - Last index. - - Z (input) DOUBLE PRECISION array, dimension ( 4*N ) - Z holds the qd array. - - PP (input) INTEGER - PP=0 for ping, PP=1 for pong. - - DMIN (output) DOUBLE PRECISION - Minimum value of d. - - SIGMA (output) DOUBLE PRECISION - Sum of shifts used in current segment. - - DESIG (input/output) DOUBLE PRECISION - Lower order part of SIGMA - - QMAX (input) DOUBLE PRECISION - Maximum value of q. - - NFAIL (output) INTEGER - Number of times shift was too big. - - ITER (output) INTEGER - Number of iterations. - - NDIV (output) INTEGER - Number of divisions. - - TTYPE (output) INTEGER - Shift type. - - IEEE (input) LOGICAL - Flag for IEEE or non IEEE arithmetic (passed to DLASQ5). - - ===================================================================== - - Parameter adjustments */ - /* Initialized data */ - static integer ttype = 0; - static doublereal dmin1 = 0.; - static doublereal dmin2 = 0.; - static doublereal dn = 0.; - static doublereal dn1 = 0.; - static doublereal dn2 = 0.; - static doublereal tau = 0.; - /* System generated locals */ - integer i__1; - doublereal d__1, d__2; - /* Builtin functions */ - double sqrt(doublereal); - /* Local variables */ - static doublereal temp, s, t; - static integer j4; - extern /* Subroutine */ int dlasq4_(integer *, integer *, doublereal *, - integer *, integer *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *) - , dlasq5_(integer *, integer *, doublereal *, integer *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, logical *), dlasq6_( - integer *, integer *, doublereal *, integer *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *); - extern doublereal dlamch_(char *); - static integer nn; - static doublereal safmin, eps, tol; - static integer n0in, ipn4; - static doublereal tol2; - - --z__; - - /* Function Body */ - - n0in = *n0; - eps = dlamch_("Precision"); - safmin = dlamch_("Safe minimum"); - tol = eps * 100.; -/* Computing 2nd power */ - d__1 = tol; - tol2 = d__1 * d__1; - -/* Check for deflation. */ - -L10: - - if (*n0 < *i0) { - return 0; - } - if (*n0 == *i0) { - goto L20; - } - nn = (*n0 << 2) + *pp; - if (*n0 == *i0 + 1) { - goto L40; - } - -/* Check whether E(N0-1) is negligible, 1 eigenvalue. */ - - if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) - - 4] > tol2 * z__[nn - 7]) { - goto L30; - } - -L20: - - z__[(*n0 << 2) - 3] = z__[(*n0 << 2) + *pp - 3] + *sigma; - --(*n0); - goto L10; - -/* Check whether E(N0-2) is negligible, 2 eigenvalues. */ - -L30: - - if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[ - nn - 11]) { - goto L50; - } - -L40: - - if (z__[nn - 3] > z__[nn - 7]) { - s = z__[nn - 3]; - z__[nn - 3] = z__[nn - 7]; - z__[nn - 7] = s; - } - if (z__[nn - 5] > z__[nn - 3] * tol2) { - t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5; - s = z__[nn - 3] * (z__[nn - 5] / t); - if (s <= t) { - s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.) + 1.))); - } else { - s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s))); - } - t = z__[nn - 7] + (s + z__[nn - 5]); - z__[nn - 3] *= z__[nn - 7] / t; - z__[nn - 7] = t; - } - z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma; - z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma; - *n0 += -2; - goto L10; - -L50: - -/* Reverse the qd-array, if warranted. */ - - if (*dmin__ <= 0. || *n0 < n0in) { - if (z__[(*i0 << 2) + *pp - 3] * 1.5 < z__[(*n0 << 2) + *pp - 3]) { - ipn4 = (*i0 + *n0) << 2; - i__1 = (*i0 + *n0 - 1) << 1; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - temp = z__[j4 - 3]; - z__[j4 - 3] = z__[ipn4 - j4 - 3]; - z__[ipn4 - j4 - 3] = temp; - temp = z__[j4 - 2]; - z__[j4 - 2] = z__[ipn4 - j4 - 2]; - z__[ipn4 - j4 - 2] = temp; - temp = z__[j4 - 1]; - z__[j4 - 1] = z__[ipn4 - j4 - 5]; - z__[ipn4 - j4 - 5] = temp; - temp = z__[j4]; - z__[j4] = z__[ipn4 - j4 - 4]; - z__[ipn4 - j4 - 4] = temp; -/* L60: */ - } - if (*n0 - *i0 <= 4) { - z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1]; - z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp]; - } -/* Computing MIN */ - d__1 = dmin2, d__2 = z__[(*n0 << 2) + *pp - 1]; - dmin2 = min(d__1,d__2); -/* Computing MIN */ - d__1 = z__[(*n0 << 2) + *pp - 1], d__2 = z__[(*i0 << 2) + *pp - 1] - , d__1 = min(d__1,d__2), d__2 = z__[(*i0 << 2) + *pp + 3]; - z__[(*n0 << 2) + *pp - 1] = min(d__1,d__2); -/* Computing MIN */ - d__1 = z__[(*n0 << 2) - *pp], d__2 = z__[(*i0 << 2) - *pp], d__1 = - min(d__1,d__2), d__2 = z__[(*i0 << 2) - *pp + 4]; - z__[(*n0 << 2) - *pp] = min(d__1,d__2); -/* Computing MAX */ - d__1 = *qmax, d__2 = z__[(*i0 << 2) + *pp - 3], d__1 = max(d__1, - d__2), d__2 = z__[(*i0 << 2) + *pp + 1]; - *qmax = max(d__1,d__2); - *dmin__ = 0.; - } - } - -/* L70: - - Computing MIN */ - d__1 = z__[(*n0 << 2) + *pp - 1], d__2 = z__[(*n0 << 2) + *pp - 9], d__1 = - min(d__1,d__2), d__2 = dmin2 + z__[(*n0 << 2) - *pp]; - if (*dmin__ < 0. || safmin * *qmax < min(d__1,d__2)) { - -/* Choose a shift. */ - - dlasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, &dmin1, &dmin2, &dn, &dn1, - &dn2, &tau, &ttype); - -/* Call dqds until DMIN > 0. */ - -L80: - - dlasq5_(i0, n0, &z__[1], pp, &tau, dmin__, &dmin1, &dmin2, &dn, &dn1, - &dn2, ieee); - - *ndiv += *n0 - *i0 + 2; - ++(*iter); - -/* Check status. */ - - if (*dmin__ >= 0. && dmin1 > 0.) { - -/* Success. */ - - goto L100; - - } else if (*dmin__ < 0. && dmin1 > 0. && z__[((*n0 - 1) << 2) - *pp] < - tol * (*sigma + dn1) && abs(dn) < tol * *sigma) { - -/* Convergence hidden by negative DN. */ - - z__[((*n0 - 1) << 2) - *pp + 2] = 0.; - *dmin__ = 0.; - goto L100; - } else if (*dmin__ < 0.) { - -/* TAU too big. Select new TAU and try again. */ - - ++(*nfail); - if (ttype < -22) { - -/* Failed twice. Play it safe. */ - - tau = 0.; - } else if (dmin1 > 0.) { - -/* Late failure. Gives excellent shift. */ - - tau = (tau + *dmin__) * (1. - eps * 2.); - ttype += -11; - } else { - -/* Early failure. Divide by 4. */ - - tau *= .25; - ttype += -12; - } - goto L80; - } else if (*dmin__ != *dmin__) { - -/* NaN. */ - - tau = 0.; - goto L80; - } else { - -/* Possible underflow. Play it safe. */ - - goto L90; - } - } - -/* Risk of underflow. */ - -L90: - dlasq6_(i0, n0, &z__[1], pp, dmin__, &dmin1, &dmin2, &dn, &dn1, &dn2); - *ndiv += *n0 - *i0 + 2; - ++(*iter); - tau = 0.; - -L100: - if (tau < *sigma) { - *desig += tau; - t = *sigma + *desig; - *desig -= t - *sigma; - } else { - t = *sigma + tau; - *desig = *sigma - (t - tau) + *desig; - } - *sigma = t; - - return 0; - -/* End of DLASQ3 */ - -} /* dlasq3_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlasq4.c b/ext/f2c_lapack/dlasq4.c deleted file mode 100644 index 658c2207a..000000000 --- a/ext/f2c_lapack/dlasq4.c +++ /dev/null @@ -1,387 +0,0 @@ -#include "blaswrap.h" -/* -- translated by f2c (version 19990503). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlasq4_(integer *i0, integer *n0, doublereal *z__, - integer *pp, integer *n0in, doublereal *dmin__, doublereal *dmin1, - doublereal *dmin2, doublereal *dn, doublereal *dn1, doublereal *dn2, - doublereal *tau, integer *ttype) -{ - /* Initialized data */ - - static doublereal g = 0.; - - /* System generated locals */ - integer i__1; - doublereal d__1, d__2; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - static doublereal s, a2, b1, b2; - static integer i4, nn, np; - static doublereal gam, gap1, gap2; - - -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1999 - - - Purpose - ======= - - DLASQ4 computes an approximation TAU to the smallest eigenvalue - using values of d from the previous transform. - - I0 (input) INTEGER - First index. - - N0 (input) INTEGER - Last index. - - Z (input) DOUBLE PRECISION array, dimension ( 4*N ) - Z holds the qd array. - - PP (input) INTEGER - PP=0 for ping, PP=1 for pong. - - NOIN (input) INTEGER - The value of N0 at start of EIGTEST. - - DMIN (input) DOUBLE PRECISION - Minimum value of d. - - DMIN1 (input) DOUBLE PRECISION - Minimum value of d, excluding D( N0 ). - - DMIN2 (input) DOUBLE PRECISION - Minimum value of d, excluding D( N0 ) and D( N0-1 ). - - DN (input) DOUBLE PRECISION - d(N) - - DN1 (input) DOUBLE PRECISION - d(N-1) - - DN2 (input) DOUBLE PRECISION - d(N-2) - - TAU (output) DOUBLE PRECISION - This is the shift. - - TTYPE (output) INTEGER - Shift type. - - Further Details - =============== - CNST1 = 9/16 - - ===================================================================== - - Parameter adjustments */ - --z__; - - /* Function Body - - A negative DMIN forces the shift to take that absolute value - TTYPE records the type of shift. */ - - if (*dmin__ <= 0.) { - *tau = -(*dmin__); - *ttype = -1; - return 0; - } - - nn = (*n0 << 2) + *pp; - if (*n0in == *n0) { - -/* No eigenvalues deflated. */ - - if (*dmin__ == *dn || *dmin__ == *dn1) { - - b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]); - b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]); - a2 = z__[nn - 7] + z__[nn - 5]; - -/* Cases 2 and 3. */ - - if (*dmin__ == *dn && *dmin1 == *dn1) { - gap2 = *dmin2 - a2 - *dmin2 * .25; - if (gap2 > 0. && gap2 > b2) { - gap1 = a2 - *dn - b2 / gap2 * b2; - } else { - gap1 = a2 - *dn - (b1 + b2); - } - if (gap1 > 0. && gap1 > b1) { -/* Computing MAX */ - d__1 = *dn - b1 / gap1 * b1, d__2 = *dmin__ * .5; - s = max(d__1,d__2); - *ttype = -2; - } else { - s = 0.; - if (*dn > b1) { - s = *dn - b1; - } - if (a2 > b1 + b2) { -/* Computing MIN */ - d__1 = s, d__2 = a2 - (b1 + b2); - s = min(d__1,d__2); - } -/* Computing MAX */ - d__1 = s, d__2 = *dmin__ * .333; - s = max(d__1,d__2); - *ttype = -3; - } - } else { - -/* Case 4. */ - - *ttype = -4; - s = *dmin__ * .25; - if (*dmin__ == *dn) { - gam = *dn; - a2 = 0.; - if (z__[nn - 5] > z__[nn - 7]) { - return 0; - } - b2 = z__[nn - 5] / z__[nn - 7]; - np = nn - 9; - } else { - np = nn - (*pp << 1); - b2 = z__[np - 2]; - gam = *dn1; - if (z__[np - 4] > z__[np - 2]) { - return 0; - } - a2 = z__[np - 4] / z__[np - 2]; - if (z__[nn - 9] > z__[nn - 11]) { - return 0; - } - b2 = z__[nn - 9] / z__[nn - 11]; - np = nn - 13; - } - -/* Approximate contribution to norm squared from I < NN-1. */ - - a2 += b2; - i__1 = (*i0 << 2) - 1 + *pp; - for (i4 = np; i4 >= i__1; i4 += -4) { - if (b2 == 0.) { - goto L20; - } - b1 = b2; - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b2 *= z__[i4] / z__[i4 - 2]; - a2 += b2; - if (max(b2,b1) * 100. < a2 || .563 < a2) { - goto L20; - } -/* L10: */ - } -L20: - a2 *= 1.05; - -/* Rayleigh quotient residual bound. */ - - if (a2 < .563) { - s = gam * (1. - sqrt(a2)) / (a2 + 1.); - } - } - } else if (*dmin__ == *dn2) { - -/* Case 5. */ - - *ttype = -5; - s = *dmin__ * .25; - -/* Compute contribution to norm squared from I > NN-2. */ - - np = nn - (*pp << 1); - b1 = z__[np - 2]; - b2 = z__[np - 6]; - gam = *dn2; - if (z__[np - 8] > b2 || z__[np - 4] > b1) { - return 0; - } - a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.); - -/* Approximate contribution to norm squared from I < NN-2. */ - - if (*n0 - *i0 > 2) { - b2 = z__[nn - 13] / z__[nn - 15]; - a2 += b2; - i__1 = (*i0 << 2) - 1 + *pp; - for (i4 = nn - 17; i4 >= i__1; i4 += -4) { - if (b2 == 0.) { - goto L40; - } - b1 = b2; - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b2 *= z__[i4] / z__[i4 - 2]; - a2 += b2; - if (max(b2,b1) * 100. < a2 || .563 < a2) { - goto L40; - } -/* L30: */ - } -L40: - a2 *= 1.05; - } - - if (a2 < .563) { - s = gam * (1. - sqrt(a2)) / (a2 + 1.); - } - } else { - -/* Case 6, no information to guide us. */ - - if (*ttype == -6) { - g += (1. - g) * .333; - } else if (*ttype == -18) { - g = .083250000000000005; - } else { - g = .25; - } - s = g * *dmin__; - *ttype = -6; - } - - } else if (*n0in == *n0 + 1) { - -/* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */ - - if (*dmin1 == *dn1 && *dmin2 == *dn2) { - -/* Cases 7 and 8. */ - - *ttype = -7; - s = *dmin1 * .333; - if (z__[nn - 5] > z__[nn - 7]) { - return 0; - } - b1 = z__[nn - 5] / z__[nn - 7]; - b2 = b1; - if (b2 == 0.) { - goto L60; - } - i__1 = (*i0 << 2) - 1 + *pp; - for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { - a2 = b1; - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b1 *= z__[i4] / z__[i4 - 2]; - b2 += b1; - if (max(b1,a2) * 100. < b2) { - goto L60; - } -/* L50: */ - } -L60: - b2 = sqrt(b2 * 1.05); -/* Computing 2nd power */ - d__1 = b2; - a2 = *dmin1 / (d__1 * d__1 + 1.); - gap2 = *dmin2 * .5 - a2; - if (gap2 > 0. && gap2 > b2 * a2) { -/* Computing MAX */ - d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); - s = max(d__1,d__2); - } else { -/* Computing MAX */ - d__1 = s, d__2 = a2 * (1. - b2 * 1.01); - s = max(d__1,d__2); - *ttype = -8; - } - } else { - -/* Case 9. */ - - s = *dmin1 * .25; - if (*dmin1 == *dn1) { - s = *dmin1 * .5; - } - *ttype = -9; - } - - } else if (*n0in == *n0 + 2) { - -/* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. - - Cases 10 and 11. */ - - if (*dmin2 == *dn2 && z__[nn - 5] * 2. < z__[nn - 7]) { - *ttype = -10; - s = *dmin2 * .333; - if (z__[nn - 5] > z__[nn - 7]) { - return 0; - } - b1 = z__[nn - 5] / z__[nn - 7]; - b2 = b1; - if (b2 == 0.) { - goto L80; - } - i__1 = (*i0 << 2) - 1 + *pp; - for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { - if (z__[i4] > z__[i4 - 2]) { - return 0; - } - b1 *= z__[i4] / z__[i4 - 2]; - b2 += b1; - if (b1 * 100. < b2) { - goto L80; - } -/* L70: */ - } -L80: - b2 = sqrt(b2 * 1.05); -/* Computing 2nd power */ - d__1 = b2; - a2 = *dmin2 / (d__1 * d__1 + 1.); - gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[ - nn - 9]) - a2; - if (gap2 > 0. && gap2 > b2 * a2) { -/* Computing MAX */ - d__1 = s, d__2 = a2 * (1. - a2 * 1.01 * (b2 / gap2) * b2); - s = max(d__1,d__2); - } else { -/* Computing MAX */ - d__1 = s, d__2 = a2 * (1. - b2 * 1.01); - s = max(d__1,d__2); - } - } else { - s = *dmin2 * .25; - *ttype = -11; - } - } else if (*n0in > *n0 + 2) { - -/* Case 12, more than two eigenvalues deflated. No information. */ - - s = 0.; - *ttype = -12; - } - - *tau = s; - return 0; - -/* End of DLASQ4 */ - -} /* dlasq4_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlasq5.c b/ext/f2c_lapack/dlasq5.c deleted file mode 100644 index 439e49036..000000000 --- a/ext/f2c_lapack/dlasq5.c +++ /dev/null @@ -1,216 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlasq5_(integer *i0, integer *n0, doublereal *z__, - integer *pp, doublereal *tau, doublereal *dmin__, doublereal *dmin1, - doublereal *dmin2, doublereal *dn, doublereal *dnm1, doublereal *dnm2, - logical *ieee) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - May 17, 2000 - - - Purpose - ======= - - DLASQ5 computes one dqds transform in ping-pong form, one - version for IEEE machines another for non IEEE machines. - - Arguments - ========= - - I0 (input) INTEGER - First index. - - N0 (input) INTEGER - Last index. - - Z (input) DOUBLE PRECISION array, dimension ( 4*N ) - Z holds the qd array. EMIN is stored in Z(4*N0) to avoid - an extra argument. - - PP (input) INTEGER - PP=0 for ping, PP=1 for pong. - - TAU (input) DOUBLE PRECISION - This is the shift. - - DMIN (output) DOUBLE PRECISION - Minimum value of d. - - DMIN1 (output) DOUBLE PRECISION - Minimum value of d, excluding D( N0 ). - - DMIN2 (output) DOUBLE PRECISION - Minimum value of d, excluding D( N0 ) and D( N0-1 ). - - DN (output) DOUBLE PRECISION - d(N0), the last value of d. - - DNM1 (output) DOUBLE PRECISION - d(N0-1). - - DNM2 (output) DOUBLE PRECISION - d(N0-2). - - IEEE (input) LOGICAL - Flag for IEEE or non IEEE arithmetic. - - ===================================================================== - - - Parameter adjustments */ - /* System generated locals */ - integer i__1; - doublereal d__1, d__2; - /* Local variables */ - static doublereal emin, temp, d__; - static integer j4, j4p2; - - --z__; - - /* Function Body */ - if (*n0 - *i0 - 1 <= 0) { - return 0; - } - - j4 = (*i0 << 2) + *pp - 3; - emin = z__[j4 + 4]; - d__ = z__[j4] - *tau; - *dmin__ = d__; - *dmin1 = -z__[j4]; - - if (*ieee) { - -/* Code for IEEE arithmetic. */ - - if (*pp == 0) { - i__1 = (*n0 - 3) << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 2] = d__ + z__[j4 - 1]; - temp = z__[j4 + 1] / z__[j4 - 2]; - d__ = d__ * temp - *tau; - *dmin__ = min(*dmin__,d__); - z__[j4] = z__[j4 - 1] * temp; -/* Computing MIN */ - d__1 = z__[j4]; - emin = min(d__1,emin); -/* L10: */ - } - } else { - i__1 = (*n0 - 3) << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 3] = d__ + z__[j4]; - temp = z__[j4 + 2] / z__[j4 - 3]; - d__ = d__ * temp - *tau; - *dmin__ = min(*dmin__,d__); - z__[j4 - 1] = z__[j4] * temp; -/* Computing MIN */ - d__1 = z__[j4 - 1]; - emin = min(d__1,emin); -/* L20: */ - } - } - -/* Unroll last two steps. */ - - *dnm2 = d__; - *dmin2 = *dmin__; - j4 = ((*n0 - 2) << 2) - *pp; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm2 + z__[j4p2]; - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; - *dmin__ = min(*dmin__,*dnm1); - - *dmin1 = *dmin__; - j4 += 4; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm1 + z__[j4p2]; - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; - *dmin__ = min(*dmin__,*dn); - - } else { - -/* Code for non IEEE arithmetic. */ - - if (*pp == 0) { - i__1 = (*n0 - 3) << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 2] = d__ + z__[j4 - 1]; - if (d__ < 0.) { - return 0; - } else { - z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); - d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau; - } - *dmin__ = min(*dmin__,d__); -/* Computing MIN */ - d__1 = emin, d__2 = z__[j4]; - emin = min(d__1,d__2); -/* L30: */ - } - } else { - i__1 = (*n0 - 3) << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 3] = d__ + z__[j4]; - if (d__ < 0.) { - return 0; - } else { - z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); - d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau; - } - *dmin__ = min(*dmin__,d__); -/* Computing MIN */ - d__1 = emin, d__2 = z__[j4 - 1]; - emin = min(d__1,d__2); -/* L40: */ - } - } - -/* Unroll last two steps. */ - - *dnm2 = d__; - *dmin2 = *dmin__; - j4 = ((*n0 - 2) << 2) - *pp; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm2 + z__[j4p2]; - if (*dnm2 < 0.) { - return 0; - } else { - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; - } - *dmin__ = min(*dmin__,*dnm1); - - *dmin1 = *dmin__; - j4 += 4; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm1 + z__[j4p2]; - if (*dnm1 < 0.) { - return 0; - } else { - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; - } - *dmin__ = min(*dmin__,*dn); - - } - - z__[j4 + 2] = *dn; - z__[(*n0 << 2) - *pp] = emin; - return 0; - -/* End of DLASQ5 */ - -} /* dlasq5_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlasq6.c b/ext/f2c_lapack/dlasq6.c deleted file mode 100644 index 57b802c37..000000000 --- a/ext/f2c_lapack/dlasq6.c +++ /dev/null @@ -1,194 +0,0 @@ -#include "blaswrap.h" -/* -- translated by f2c (version 19990503). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlasq6_(integer *i0, integer *n0, doublereal *z__, - integer *pp, doublereal *dmin__, doublereal *dmin1, doublereal *dmin2, - doublereal *dn, doublereal *dnm1, doublereal *dnm2) -{ - /* System generated locals */ - integer i__1; - doublereal d__1, d__2; - - /* Local variables */ - static doublereal emin, temp, d__; - static integer j4; - extern doublereal dlamch_(char *); - static doublereal safmin; - static integer j4p2; - - -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1999 - - - Purpose - ======= - - DLASQ6 computes one dqd (shift equal to zero) transform in - ping-pong form, with protection against underflow and overflow. - - Arguments - ========= - - I0 (input) INTEGER - First index. - - N0 (input) INTEGER - Last index. - - Z (input) DOUBLE PRECISION array, dimension ( 4*N ) - Z holds the qd array. EMIN is stored in Z(4*N0) to avoid - an extra argument. - - PP (input) INTEGER - PP=0 for ping, PP=1 for pong. - - DMIN (output) DOUBLE PRECISION - Minimum value of d. - - DMIN1 (output) DOUBLE PRECISION - Minimum value of d, excluding D( N0 ). - - DMIN2 (output) DOUBLE PRECISION - Minimum value of d, excluding D( N0 ) and D( N0-1 ). - - DN (output) DOUBLE PRECISION - d(N0), the last value of d. - - DNM1 (output) DOUBLE PRECISION - d(N0-1). - - DNM2 (output) DOUBLE PRECISION - d(N0-2). - - ===================================================================== - - - Parameter adjustments */ - --z__; - - /* Function Body */ - if (*n0 - *i0 - 1 <= 0) { - return 0; - } - - safmin = dlamch_("Safe minimum"); - j4 = (*i0 << 2) + *pp - 3; - emin = z__[j4 + 4]; - d__ = z__[j4]; - *dmin__ = d__; - - if (*pp == 0) { - i__1 = (*n0 - 3) << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 2] = d__ + z__[j4 - 1]; - if (z__[j4 - 2] == 0.) { - z__[j4] = 0.; - d__ = z__[j4 + 1]; - *dmin__ = d__; - emin = 0.; - } else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4 - - 2] < z__[j4 + 1]) { - temp = z__[j4 + 1] / z__[j4 - 2]; - z__[j4] = z__[j4 - 1] * temp; - d__ *= temp; - } else { - z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); - d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]); - } - *dmin__ = min(*dmin__,d__); -/* Computing MIN */ - d__1 = emin, d__2 = z__[j4]; - emin = min(d__1,d__2); -/* L10: */ - } - } else { - i__1 = (*n0 - 3) << 2; - for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { - z__[j4 - 3] = d__ + z__[j4]; - if (z__[j4 - 3] == 0.) { - z__[j4 - 1] = 0.; - d__ = z__[j4 + 2]; - *dmin__ = d__; - emin = 0.; - } else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4 - - 3] < z__[j4 + 2]) { - temp = z__[j4 + 2] / z__[j4 - 3]; - z__[j4 - 1] = z__[j4] * temp; - d__ *= temp; - } else { - z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); - d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]); - } - *dmin__ = min(*dmin__,d__); -/* Computing MIN */ - d__1 = emin, d__2 = z__[j4 - 1]; - emin = min(d__1,d__2); -/* L20: */ - } - } - -/* Unroll last two steps. */ - - *dnm2 = d__; - *dmin2 = *dmin__; - j4 = ((*n0 - 2) << 2) - *pp; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm2 + z__[j4p2]; - if (z__[j4 - 2] == 0.) { - z__[j4] = 0.; - *dnm1 = z__[j4p2 + 2]; - *dmin__ = *dnm1; - emin = 0.; - } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < - z__[j4p2 + 2]) { - temp = z__[j4p2 + 2] / z__[j4 - 2]; - z__[j4] = z__[j4p2] * temp; - *dnm1 = *dnm2 * temp; - } else { - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]); - } - *dmin__ = min(*dmin__,*dnm1); - - *dmin1 = *dmin__; - j4 += 4; - j4p2 = j4 + (*pp << 1) - 1; - z__[j4 - 2] = *dnm1 + z__[j4p2]; - if (z__[j4 - 2] == 0.) { - z__[j4] = 0.; - *dn = z__[j4p2 + 2]; - *dmin__ = *dn; - emin = 0.; - } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < - z__[j4p2 + 2]) { - temp = z__[j4p2 + 2] / z__[j4 - 2]; - z__[j4] = z__[j4p2] * temp; - *dn = *dnm1 * temp; - } else { - z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); - *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]); - } - *dmin__ = min(*dmin__,*dn); - - z__[j4 + 2] = *dn; - z__[(*n0 << 2) - *pp] = emin; - return 0; - -/* End of DLASQ6 */ - -} /* dlasq6_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlasr.c b/ext/f2c_lapack/dlasr.c deleted file mode 100644 index c40ae9d40..000000000 --- a/ext/f2c_lapack/dlasr.c +++ /dev/null @@ -1,400 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlasr_(char *side, char *pivot, char *direct, integer *m, - integer *n, doublereal *c__, doublereal *s, doublereal *a, integer * - lda) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1992 - - - Purpose - ======= - - DLASR performs the transformation - - A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) - - A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) - - where A is an m by n real matrix and P is an orthogonal matrix, - consisting of a sequence of plane rotations determined by the - parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' - and z = n when SIDE = 'R' or 'r' ): - - When DIRECT = 'F' or 'f' ( Forward sequence ) then - - P = P( z - 1 )*...*P( 2 )*P( 1 ), - - and when DIRECT = 'B' or 'b' ( Backward sequence ) then - - P = P( 1 )*P( 2 )*...*P( z - 1 ), - - where P( k ) is a plane rotation matrix for the following planes: - - when PIVOT = 'V' or 'v' ( Variable pivot ), - the plane ( k, k + 1 ) - - when PIVOT = 'T' or 't' ( Top pivot ), - the plane ( 1, k + 1 ) - - when PIVOT = 'B' or 'b' ( Bottom pivot ), - the plane ( k, z ) - - c( k ) and s( k ) must contain the cosine and sine that define the - matrix P( k ). The two by two plane rotation part of the matrix - P( k ), R( k ), is assumed to be of the form - - R( k ) = ( c( k ) s( k ) ). - ( -s( k ) c( k ) ) - - This version vectorises across rows of the array A when SIDE = 'L'. - - Arguments - ========= - - SIDE (input) CHARACTER*1 - Specifies whether the plane rotation matrix P is applied to - A on the left or the right. - = 'L': Left, compute A := P*A - = 'R': Right, compute A:= A*P' - - DIRECT (input) CHARACTER*1 - Specifies whether P is a forward or backward sequence of - plane rotations. - = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) - = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) - - PIVOT (input) CHARACTER*1 - Specifies the plane for which P(k) is a plane rotation - matrix. - = 'V': Variable pivot, the plane (k,k+1) - = 'T': Top pivot, the plane (1,k+1) - = 'B': Bottom pivot, the plane (k,z) - - M (input) INTEGER - The number of rows of the matrix A. If m <= 1, an immediate - return is effected. - - N (input) INTEGER - The number of columns of the matrix A. If n <= 1, an - immediate return is effected. - - C, S (input) DOUBLE PRECISION arrays, dimension - (M-1) if SIDE = 'L' - (N-1) if SIDE = 'R' - c(k) and s(k) contain the cosine and sine that define the - matrix P(k). The two by two plane rotation part of the - matrix P(k), R(k), is assumed to be of the form - R( k ) = ( c( k ) s( k ) ). - ( -s( k ) c( k ) ) - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - The m by n matrix A. On exit, A is overwritten by P*A if - SIDE = 'R' or by A*P' if SIDE = 'L'. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - ===================================================================== - - - Test the input parameters - - Parameter adjustments */ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - /* Local variables */ - static integer info; - static doublereal temp; - static integer i__, j; - extern logical lsame_(char *, char *); - static doublereal ctemp, stemp; - extern /* Subroutine */ int xerbla_(char *, integer *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - --c__; - --s; - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ - info = 0; - if (! (lsame_(side, "L") || lsame_(side, "R"))) { - info = 1; - } else if (! (lsame_(pivot, "V") || lsame_(pivot, - "T") || lsame_(pivot, "B"))) { - info = 2; - } else if (! (lsame_(direct, "F") || lsame_(direct, - "B"))) { - info = 3; - } else if (*m < 0) { - info = 4; - } else if (*n < 0) { - info = 5; - } else if (*lda < max(1,*m)) { - info = 9; - } - if (info != 0) { - xerbla_("DLASR ", &info); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - return 0; - } - if (lsame_(side, "L")) { - -/* Form P * A */ - - if (lsame_(pivot, "V")) { - if (lsame_(direct, "F")) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a_ref(j + 1, i__); - a_ref(j + 1, i__) = ctemp * temp - stemp * a_ref( - j, i__); - a_ref(j, i__) = stemp * temp + ctemp * a_ref(j, - i__); -/* L10: */ - } - } -/* L20: */ - } - } else if (lsame_(direct, "B")) { - for (j = *m - 1; j >= 1; --j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a_ref(j + 1, i__); - a_ref(j + 1, i__) = ctemp * temp - stemp * a_ref( - j, i__); - a_ref(j, i__) = stemp * temp + ctemp * a_ref(j, - i__); -/* L30: */ - } - } -/* L40: */ - } - } - } else if (lsame_(pivot, "T")) { - if (lsame_(direct, "F")) { - i__1 = *m; - for (j = 2; j <= i__1; ++j) { - ctemp = c__[j - 1]; - stemp = s[j - 1]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a_ref(j, i__); - a_ref(j, i__) = ctemp * temp - stemp * a_ref(1, - i__); - a_ref(1, i__) = stemp * temp + ctemp * a_ref(1, - i__); -/* L50: */ - } - } -/* L60: */ - } - } else if (lsame_(direct, "B")) { - for (j = *m; j >= 2; --j) { - ctemp = c__[j - 1]; - stemp = s[j - 1]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a_ref(j, i__); - a_ref(j, i__) = ctemp * temp - stemp * a_ref(1, - i__); - a_ref(1, i__) = stemp * temp + ctemp * a_ref(1, - i__); -/* L70: */ - } - } -/* L80: */ - } - } - } else if (lsame_(pivot, "B")) { - if (lsame_(direct, "F")) { - i__1 = *m - 1; - for (j = 1; j <= i__1; ++j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *n; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a_ref(j, i__); - a_ref(j, i__) = stemp * a_ref(*m, i__) + ctemp * - temp; - a_ref(*m, i__) = ctemp * a_ref(*m, i__) - stemp * - temp; -/* L90: */ - } - } -/* L100: */ - } - } else if (lsame_(direct, "B")) { - for (j = *m - 1; j >= 1; --j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a_ref(j, i__); - a_ref(j, i__) = stemp * a_ref(*m, i__) + ctemp * - temp; - a_ref(*m, i__) = ctemp * a_ref(*m, i__) - stemp * - temp; -/* L110: */ - } - } -/* L120: */ - } - } - } - } else if (lsame_(side, "R")) { - -/* Form A * P' */ - - if (lsame_(pivot, "V")) { - if (lsame_(direct, "F")) { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a_ref(i__, j + 1); - a_ref(i__, j + 1) = ctemp * temp - stemp * a_ref( - i__, j); - a_ref(i__, j) = stemp * temp + ctemp * a_ref(i__, - j); -/* L130: */ - } - } -/* L140: */ - } - } else if (lsame_(direct, "B")) { - for (j = *n - 1; j >= 1; --j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a_ref(i__, j + 1); - a_ref(i__, j + 1) = ctemp * temp - stemp * a_ref( - i__, j); - a_ref(i__, j) = stemp * temp + ctemp * a_ref(i__, - j); -/* L150: */ - } - } -/* L160: */ - } - } - } else if (lsame_(pivot, "T")) { - if (lsame_(direct, "F")) { - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - ctemp = c__[j - 1]; - stemp = s[j - 1]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a_ref(i__, j); - a_ref(i__, j) = ctemp * temp - stemp * a_ref(i__, - 1); - a_ref(i__, 1) = stemp * temp + ctemp * a_ref(i__, - 1); -/* L170: */ - } - } -/* L180: */ - } - } else if (lsame_(direct, "B")) { - for (j = *n; j >= 2; --j) { - ctemp = c__[j - 1]; - stemp = s[j - 1]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a_ref(i__, j); - a_ref(i__, j) = ctemp * temp - stemp * a_ref(i__, - 1); - a_ref(i__, 1) = stemp * temp + ctemp * a_ref(i__, - 1); -/* L190: */ - } - } -/* L200: */ - } - } - } else if (lsame_(pivot, "B")) { - if (lsame_(direct, "F")) { - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { - temp = a_ref(i__, j); - a_ref(i__, j) = stemp * a_ref(i__, *n) + ctemp * - temp; - a_ref(i__, *n) = ctemp * a_ref(i__, *n) - stemp * - temp; -/* L210: */ - } - } -/* L220: */ - } - } else if (lsame_(direct, "B")) { - for (j = *n - 1; j >= 1; --j) { - ctemp = c__[j]; - stemp = s[j]; - if (ctemp != 1. || stemp != 0.) { - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { - temp = a_ref(i__, j); - a_ref(i__, j) = stemp * a_ref(i__, *n) + ctemp * - temp; - a_ref(i__, *n) = ctemp * a_ref(i__, *n) - stemp * - temp; -/* L230: */ - } - } -/* L240: */ - } - } - } - } - - return 0; - -/* End of DLASR */ - -} /* dlasr_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlasrt.c b/ext/f2c_lapack/dlasrt.c deleted file mode 100644 index c0416a77b..000000000 --- a/ext/f2c_lapack/dlasrt.c +++ /dev/null @@ -1,266 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlasrt_(char *id, integer *n, doublereal *d__, integer * - info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - September 30, 1994 - - - Purpose - ======= - - Sort the numbers in D in increasing order (if ID = 'I') or - in decreasing order (if ID = 'D' ). - - Use Quick Sort, reverting to Insertion sort on arrays of - size <= 20. Dimension of STACK limits N to about 2**32. - - Arguments - ========= - - ID (input) CHARACTER*1 - = 'I': sort D in increasing order; - = 'D': sort D in decreasing order. - - N (input) INTEGER - The length of the array D. - - D (input/output) DOUBLE PRECISION array, dimension (N) - On entry, the array to be sorted. - On exit, D has been sorted into increasing order - (D(1) <= ... <= D(N) ) or into decreasing order - (D(1) >= ... >= D(N) ), depending on ID. - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - - ===================================================================== - - - Test the input paramters. - - Parameter adjustments */ - /* System generated locals */ - integer i__1, i__2; - /* Local variables */ - static integer endd, i__, j; - extern logical lsame_(char *, char *); - static integer stack[64] /* was [2][32] */; - static doublereal dmnmx, d1, d2, d3; - static integer start; - extern /* Subroutine */ int xerbla_(char *, integer *); - static integer stkpnt, dir; - static doublereal tmp; -#define stack_ref(a_1,a_2) stack[(a_2)*2 + a_1 - 3] - - --d__; - - /* Function Body */ - *info = 0; - dir = -1; - if (lsame_(id, "D")) { - dir = 0; - } else if (lsame_(id, "I")) { - dir = 1; - } - if (dir == -1) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLASRT", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n <= 1) { - return 0; - } - - stkpnt = 1; - stack_ref(1, 1) = 1; - stack_ref(2, 1) = *n; -L10: - start = stack_ref(1, stkpnt); - endd = stack_ref(2, stkpnt); - --stkpnt; - if (endd - start <= 20 && endd - start > 0) { - -/* Do Insertion sort on D( START:ENDD ) */ - - if (dir == 0) { - -/* Sort into decreasing order */ - - i__1 = endd; - for (i__ = start + 1; i__ <= i__1; ++i__) { - i__2 = start + 1; - for (j = i__; j >= i__2; --j) { - if (d__[j] > d__[j - 1]) { - dmnmx = d__[j]; - d__[j] = d__[j - 1]; - d__[j - 1] = dmnmx; - } else { - goto L30; - } -/* L20: */ - } -L30: - ; - } - - } else { - -/* Sort into increasing order */ - - i__1 = endd; - for (i__ = start + 1; i__ <= i__1; ++i__) { - i__2 = start + 1; - for (j = i__; j >= i__2; --j) { - if (d__[j] < d__[j - 1]) { - dmnmx = d__[j]; - d__[j] = d__[j - 1]; - d__[j - 1] = dmnmx; - } else { - goto L50; - } -/* L40: */ - } -L50: - ; - } - - } - - } else if (endd - start > 20) { - -/* Partition D( START:ENDD ) and stack parts, largest one first - - Choose partition entry as median of 3 */ - - d1 = d__[start]; - d2 = d__[endd]; - i__ = (start + endd) / 2; - d3 = d__[i__]; - if (d1 < d2) { - if (d3 < d1) { - dmnmx = d1; - } else if (d3 < d2) { - dmnmx = d3; - } else { - dmnmx = d2; - } - } else { - if (d3 < d2) { - dmnmx = d2; - } else if (d3 < d1) { - dmnmx = d3; - } else { - dmnmx = d1; - } - } - - if (dir == 0) { - -/* Sort into decreasing order */ - - i__ = start - 1; - j = endd + 1; -L60: -L70: - --j; - if (d__[j] < dmnmx) { - goto L70; - } -L80: - ++i__; - if (d__[i__] > dmnmx) { - goto L80; - } - if (i__ < j) { - tmp = d__[i__]; - d__[i__] = d__[j]; - d__[j] = tmp; - goto L60; - } - if (j - start > endd - j - 1) { - ++stkpnt; - stack_ref(1, stkpnt) = start; - stack_ref(2, stkpnt) = j; - ++stkpnt; - stack_ref(1, stkpnt) = j + 1; - stack_ref(2, stkpnt) = endd; - } else { - ++stkpnt; - stack_ref(1, stkpnt) = j + 1; - stack_ref(2, stkpnt) = endd; - ++stkpnt; - stack_ref(1, stkpnt) = start; - stack_ref(2, stkpnt) = j; - } - } else { - -/* Sort into increasing order */ - - i__ = start - 1; - j = endd + 1; -L90: -L100: - --j; - if (d__[j] > dmnmx) { - goto L100; - } -L110: - ++i__; - if (d__[i__] < dmnmx) { - goto L110; - } - if (i__ < j) { - tmp = d__[i__]; - d__[i__] = d__[j]; - d__[j] = tmp; - goto L90; - } - if (j - start > endd - j - 1) { - ++stkpnt; - stack_ref(1, stkpnt) = start; - stack_ref(2, stkpnt) = j; - ++stkpnt; - stack_ref(1, stkpnt) = j + 1; - stack_ref(2, stkpnt) = endd; - } else { - ++stkpnt; - stack_ref(1, stkpnt) = j + 1; - stack_ref(2, stkpnt) = endd; - ++stkpnt; - stack_ref(1, stkpnt) = start; - stack_ref(2, stkpnt) = j; - } - } - } - if (stkpnt > 0) { - goto L10; - } - return 0; - -/* End of DLASRT */ - -} /* dlasrt_ */ - -#undef stack_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlassq.c b/ext/f2c_lapack/dlassq.c deleted file mode 100644 index 6a84841a9..000000000 --- a/ext/f2c_lapack/dlassq.c +++ /dev/null @@ -1,99 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlassq_(integer *n, doublereal *x, integer *incx, - doublereal *scale, doublereal *sumsq) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1999 - - - Purpose - ======= - - DLASSQ returns the values scl and smsq such that - - ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, - - where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is - assumed to be non-negative and scl returns the value - - scl = max( scale, abs( x( i ) ) ). - - scale and sumsq must be supplied in SCALE and SUMSQ and - scl and smsq are overwritten on SCALE and SUMSQ respectively. - - The routine makes only one pass through the vector x. - - Arguments - ========= - - N (input) INTEGER - The number of elements to be used from the vector X. - - X (input) DOUBLE PRECISION array, dimension (N) - The vector for which a scaled sum of squares is computed. - x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. - - INCX (input) INTEGER - The increment between successive values of the vector X. - INCX > 0. - - SCALE (input/output) DOUBLE PRECISION - On entry, the value scale in the equation above. - On exit, SCALE is overwritten with scl , the scaling factor - for the sum of squares. - - SUMSQ (input/output) DOUBLE PRECISION - On entry, the value sumsq in the equation above. - On exit, SUMSQ is overwritten with smsq , the basic sum of - squares from which scl has been factored out. - - ===================================================================== - - - Parameter adjustments */ - /* System generated locals */ - integer i__1, i__2; - doublereal d__1; - /* Local variables */ - static doublereal absxi; - static integer ix; - - --x; - - /* Function Body */ - if (*n > 0) { - i__1 = (*n - 1) * *incx + 1; - i__2 = *incx; - for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { - if (x[ix] != 0.) { - absxi = (d__1 = x[ix], abs(d__1)); - if (*scale < absxi) { -/* Computing 2nd power */ - d__1 = *scale / absxi; - *sumsq = *sumsq * (d__1 * d__1) + 1; - *scale = absxi; - } else { -/* Computing 2nd power */ - d__1 = absxi / *scale; - *sumsq += d__1 * d__1; - } - } -/* L10: */ - } - } - return 0; - -/* End of DLASSQ */ - -} /* dlassq_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlasv2.c b/ext/f2c_lapack/dlasv2.c deleted file mode 100644 index 921e76cf3..000000000 --- a/ext/f2c_lapack/dlasv2.c +++ /dev/null @@ -1,256 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlasv2_(doublereal *f, doublereal *g, doublereal *h__, - doublereal *ssmin, doublereal *ssmax, doublereal *snr, doublereal * - csr, doublereal *snl, doublereal *csl) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - October 31, 1992 - - - Purpose - ======= - - DLASV2 computes the singular value decomposition of a 2-by-2 - triangular matrix - [ F G ] - [ 0 H ]. - On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the - smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and - right singular vectors for abs(SSMAX), giving the decomposition - - [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] - [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. - - Arguments - ========= - - F (input) DOUBLE PRECISION - The (1,1) element of the 2-by-2 matrix. - - G (input) DOUBLE PRECISION - The (1,2) element of the 2-by-2 matrix. - - H (input) DOUBLE PRECISION - The (2,2) element of the 2-by-2 matrix. - - SSMIN (output) DOUBLE PRECISION - abs(SSMIN) is the smaller singular value. - - SSMAX (output) DOUBLE PRECISION - abs(SSMAX) is the larger singular value. - - SNL (output) DOUBLE PRECISION - CSL (output) DOUBLE PRECISION - The vector (CSL, SNL) is a unit left singular vector for the - singular value abs(SSMAX). - - SNR (output) DOUBLE PRECISION - CSR (output) DOUBLE PRECISION - The vector (CSR, SNR) is a unit right singular vector for the - singular value abs(SSMAX). - - Further Details - =============== - - Any input parameter may be aliased with any output parameter. - - Barring over/underflow and assuming a guard digit in subtraction, all - output quantities are correct to within a few units in the last - place (ulps). - - In IEEE arithmetic, the code works correctly if one matrix element is - infinite. - - Overflow will not occur unless the largest singular value itself - overflows or is within a few ulps of overflow. (On machines with - partial overflow, like the Cray, overflow may occur if the largest - singular value is within a factor of 2 of overflow.) - - Underflow is harmless if underflow is gradual. Otherwise, results - may correspond to a matrix modified by perturbations of size near - the underflow threshold. - - ===================================================================== */ - /* Table of constant values */ - static doublereal c_b3 = 2.; - static doublereal c_b4 = 1.; - - /* System generated locals */ - doublereal d__1; - /* Builtin functions */ - double sqrt(doublereal), d_sign(doublereal *, doublereal *); - /* Local variables */ - static integer pmax; - static doublereal temp; - static logical swap; - static doublereal a, d__, l, m, r__, s, t, tsign, fa, ga, ha; - extern doublereal dlamch_(char *); - static doublereal ft, gt, ht, mm; - static logical gasmal; - static doublereal tt, clt, crt, slt, srt; - - - - - ft = *f; - fa = abs(ft); - ht = *h__; - ha = abs(*h__); - -/* PMAX points to the maximum absolute element of matrix - PMAX = 1 if F largest in absolute values - PMAX = 2 if G largest in absolute values - PMAX = 3 if H largest in absolute values */ - - pmax = 1; - swap = ha > fa; - if (swap) { - pmax = 3; - temp = ft; - ft = ht; - ht = temp; - temp = fa; - fa = ha; - ha = temp; - -/* Now FA .ge. HA */ - - } - gt = *g; - ga = abs(gt); - if (ga == 0.) { - -/* Diagonal matrix */ - - *ssmin = ha; - *ssmax = fa; - clt = 1.; - crt = 1.; - slt = 0.; - srt = 0.; - } else { - gasmal = TRUE_; - if (ga > fa) { - pmax = 2; - if (fa / ga < dlamch_("EPS")) { - -/* Case of very large GA */ - - gasmal = FALSE_; - *ssmax = ga; - if (ha > 1.) { - *ssmin = fa / (ga / ha); - } else { - *ssmin = fa / ga * ha; - } - clt = 1.; - slt = ht / gt; - srt = 1.; - crt = ft / gt; - } - } - if (gasmal) { - -/* Normal case */ - - d__ = fa - ha; - if (d__ == fa) { - -/* Copes with infinite F or H */ - - l = 1.; - } else { - l = d__ / fa; - } - -/* Note that 0 .le. L .le. 1 */ - - m = gt / ft; - -/* Note that abs(M) .le. 1/macheps */ - - t = 2. - l; - -/* Note that T .ge. 1 */ - - mm = m * m; - tt = t * t; - s = sqrt(tt + mm); - -/* Note that 1 .le. S .le. 1 + 1/macheps */ - - if (l == 0.) { - r__ = abs(m); - } else { - r__ = sqrt(l * l + mm); - } - -/* Note that 0 .le. R .le. 1 + 1/macheps */ - - a = (s + r__) * .5; - -/* Note that 1 .le. A .le. 1 + abs(M) */ - - *ssmin = ha / a; - *ssmax = fa * a; - if (mm == 0.) { - -/* Note that M is very tiny */ - - if (l == 0.) { - t = d_sign(&c_b3, &ft) * d_sign(&c_b4, >); - } else { - t = gt / d_sign(&d__, &ft) + m / t; - } - } else { - t = (m / (s + t) + m / (r__ + l)) * (a + 1.); - } - l = sqrt(t * t + 4.); - crt = 2. / l; - srt = t / l; - clt = (crt + srt * m) / a; - slt = ht / ft * srt / a; - } - } - if (swap) { - *csl = srt; - *snl = crt; - *csr = slt; - *snr = clt; - } else { - *csl = clt; - *snl = slt; - *csr = crt; - *snr = srt; - } - -/* Correct signs of SSMAX and SSMIN */ - - if (pmax == 1) { - tsign = d_sign(&c_b4, csr) * d_sign(&c_b4, csl) * d_sign(&c_b4, f); - } - if (pmax == 2) { - tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, csl) * d_sign(&c_b4, g); - } - if (pmax == 3) { - tsign = d_sign(&c_b4, snr) * d_sign(&c_b4, snl) * d_sign(&c_b4, h__); - } - *ssmax = d_sign(ssmax, &tsign); - d__1 = tsign * d_sign(&c_b4, f) * d_sign(&c_b4, h__); - *ssmin = d_sign(ssmin, &d__1); - return 0; - -/* End of DLASV2 */ - -} /* dlasv2_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlaswp.c b/ext/f2c_lapack/dlaswp.c deleted file mode 100644 index a5af952b6..000000000 --- a/ext/f2c_lapack/dlaswp.c +++ /dev/null @@ -1,149 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dlaswp_(integer *n, doublereal *a, integer *lda, integer - *k1, integer *k2, integer *ipiv, integer *incx) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1999 - - - Purpose - ======= - - DLASWP performs a series of row interchanges on the matrix A. - One row interchange is initiated for each of rows K1 through K2 of A. - - Arguments - ========= - - N (input) INTEGER - The number of columns of the matrix A. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the matrix of column dimension N to which the row - interchanges will be applied. - On exit, the permuted matrix. - - LDA (input) INTEGER - The leading dimension of the array A. - - K1 (input) INTEGER - The first element of IPIV for which a row interchange will - be done. - - K2 (input) INTEGER - The last element of IPIV for which a row interchange will - be done. - - IPIV (input) INTEGER array, dimension (M*abs(INCX)) - The vector of pivot indices. Only the elements in positions - K1 through K2 of IPIV are accessed. - IPIV(K) = L implies rows K and L are to be interchanged. - - INCX (input) INTEGER - The increment between successive values of IPIV. If IPIV - is negative, the pivots are applied in reverse order. - - Further Details - =============== - - Modified by - R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA - - ===================================================================== - - - Interchange row I with row IPIV(I) for each of rows K1 through K2. - - Parameter adjustments */ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - /* Local variables */ - static doublereal temp; - static integer i__, j, k, i1, i2, n32, ip, ix, ix0, inc; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --ipiv; - - /* Function Body */ - if (*incx > 0) { - ix0 = *k1; - i1 = *k1; - i2 = *k2; - inc = 1; - } else if (*incx < 0) { - ix0 = (1 - *k2) * *incx + 1; - i1 = *k2; - i2 = *k1; - inc = -1; - } else { - return 0; - } - - n32 = *n / 32 << 5; - if (n32 != 0) { - i__1 = n32; - for (j = 1; j <= i__1; j += 32) { - ix = ix0; - i__2 = i2; - i__3 = inc; - for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) - { - ip = ipiv[ix]; - if (ip != i__) { - i__4 = j + 31; - for (k = j; k <= i__4; ++k) { - temp = a_ref(i__, k); - a_ref(i__, k) = a_ref(ip, k); - a_ref(ip, k) = temp; -/* L10: */ - } - } - ix += *incx; -/* L20: */ - } -/* L30: */ - } - } - if (n32 != *n) { - ++n32; - ix = ix0; - i__1 = i2; - i__3 = inc; - for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) { - ip = ipiv[ix]; - if (ip != i__) { - i__2 = *n; - for (k = n32; k <= i__2; ++k) { - temp = a_ref(i__, k); - a_ref(i__, k) = a_ref(ip, k); - a_ref(ip, k) = temp; -/* L40: */ - } - } - ix += *incx; -/* L50: */ - } - } - - return 0; - -/* End of DLASWP */ - -} /* dlaswp_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dlatbs.c b/ext/f2c_lapack/dlatbs.c deleted file mode 100644 index eaea649f4..000000000 --- a/ext/f2c_lapack/dlatbs.c +++ /dev/null @@ -1,855 +0,0 @@ -/* dlatbs.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static doublereal c_b36 = .5; - -/* Subroutine */ int dlatbs_(char *uplo, char *trans, char *diag, char * - normin, integer *n, integer *kd, doublereal *ab, integer *ldab, - doublereal *x, doublereal *scale, doublereal *cnorm, integer *info, - ftnlen uplo_len, ftnlen trans_len, ftnlen diag_len, ftnlen normin_len) -{ - /* System generated locals */ - integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; - doublereal d__1, d__2, d__3; - - /* Local variables */ - static integer i__, j; - static doublereal xj, rec, tjj; - static integer jinc, jlen; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); - static doublereal xbnd; - static integer imax; - static doublereal tmax, tjjs, xmax, grow, sumj; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - static integer maind; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - static doublereal tscal, uscal; - extern doublereal dasum_(integer *, doublereal *, integer *); - static integer jlast; - extern /* Subroutine */ int dtbsv_(char *, char *, char *, integer *, - integer *, doublereal *, integer *, doublereal *, integer *, - ftnlen, ftnlen, ftnlen), daxpy_(integer *, doublereal *, - doublereal *, integer *, doublereal *, integer *); - static logical upper; - extern doublereal dlamch_(char *, ftnlen); - extern integer idamax_(integer *, doublereal *, integer *); - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - static doublereal bignum; - static logical notran; - static integer jfirst; - static doublereal smlnum; - static logical nounit; - - -/* -- LAPACK auxiliary routine (version 3.0) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ -/* Courant Institute, Argonne National Lab, and Rice University */ -/* June 30, 1992 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLATBS solves one of the triangular systems */ - -/* A *x = s*b or A'*x = s*b */ - -/* with scaling to prevent overflow, where A is an upper or lower */ -/* triangular band matrix. Here A' denotes the transpose of A, x and b */ -/* are n-element vectors, and s is a scaling factor, usually less than */ -/* or equal to 1, chosen so that the components of x will be less than */ -/* the overflow threshold. If the unscaled problem will not cause */ -/* overflow, the Level 2 BLAS routine DTBSV is called. If the matrix A */ -/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */ -/* non-trivial solution to A*x = 0 is returned. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the matrix A is upper or lower triangular. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the operation applied to A. */ -/* = 'N': Solve A * x = s*b (No transpose) */ -/* = 'T': Solve A'* x = s*b (Transpose) */ -/* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) */ - -/* DIAG (input) CHARACTER*1 */ -/* Specifies whether or not the matrix A is unit triangular. */ -/* = 'N': Non-unit triangular */ -/* = 'U': Unit triangular */ - -/* NORMIN (input) CHARACTER*1 */ -/* Specifies whether CNORM has been set or not. */ -/* = 'Y': CNORM contains the column norms on entry */ -/* = 'N': CNORM is not set on entry. On exit, the norms will */ -/* be computed and stored in CNORM. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* KD (input) INTEGER */ -/* The number of subdiagonals or superdiagonals in the */ -/* triangular matrix A. KD >= 0. */ - -/* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) */ -/* The upper or lower triangular band matrix A, stored in the */ -/* first KD+1 rows of the array. The j-th column of A is stored */ -/* in the j-th column of the array AB as follows: */ -/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */ -/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */ - -/* LDAB (input) INTEGER */ -/* The leading dimension of the array AB. LDAB >= KD+1. */ - -/* X (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the right hand side b of the triangular system. */ -/* On exit, X is overwritten by the solution vector x. */ - -/* SCALE (output) DOUBLE PRECISION */ -/* The scaling factor s for the triangular system */ -/* A * x = s*b or A'* x = s*b. */ -/* If SCALE = 0, the matrix A is singular or badly scaled, and */ -/* the vector x is an exact or approximate solution to A*x = 0. */ - -/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */ - -/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ -/* contains the norm of the off-diagonal part of the j-th column */ -/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ -/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ -/* must be greater than or equal to the 1-norm. */ - -/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ -/* returns the 1-norm of the offdiagonal part of the j-th column */ -/* of A. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ - -/* Further Details */ -/* ======= ======= */ - -/* A rough bound on x is computed; if that is less than overflow, DTBSV */ -/* is called, otherwise, specific code is used which checks for possible */ -/* overflow or divide-by-zero at every operation. */ - -/* A columnwise scheme is used for solving A*x = b. The basic algorithm */ -/* if A is lower triangular is */ - -/* x[1:n] := b[1:n] */ -/* for j = 1, ..., n */ -/* x(j) := x(j) / A(j,j) */ -/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ -/* end */ - -/* Define bounds on the components of x after j iterations of the loop: */ -/* M(j) = bound on x[1:j] */ -/* G(j) = bound on x[j+1:n] */ -/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */ - -/* Then for iteration j+1 we have */ -/* M(j+1) <= G(j) / | A(j+1,j+1) | */ -/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ -/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ - -/* where CNORM(j+1) is greater than or equal to the infinity-norm of */ -/* column j+1 of A, not counting the diagonal. Hence */ - -/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ -/* 1<=i<=j */ -/* and */ - -/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ -/* 1<=i< j */ - -/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the */ -/* reciprocal of the largest M(j), j=1,..,n, is larger than */ -/* max(underflow, 1/overflow). */ - -/* The bound on x(j) is also used to determine when a step in the */ -/* columnwise method can be performed without fear of overflow. If */ -/* the computed bound is greater than a large constant, x is scaled to */ -/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ -/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ - -/* Similarly, a row-wise scheme is used to solve A'*x = b. The basic */ -/* algorithm for A upper triangular is */ - -/* for j = 1, ..., n */ -/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */ -/* end */ - -/* We simultaneously compute two bounds */ -/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */ -/* M(j) = bound on x(i), 1<=i<=j */ - -/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */ -/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ -/* Then the bound on x(j) is */ - -/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ - -/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ -/* 1<=i<=j */ - -/* and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater */ -/* than max(underflow, 1/overflow). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1; - ab -= ab_offset; - --x; - --cnorm; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1); - notran = lsame_(trans, "N", (ftnlen)1, (ftnlen)1); - nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1); - -/* Test the input parameters. */ - - if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T", (ftnlen)1, (ftnlen)1) && ! - lsame_(trans, "C", (ftnlen)1, (ftnlen)1)) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { - *info = -3; - } else if (! lsame_(normin, "Y", (ftnlen)1, (ftnlen)1) && ! lsame_(normin, - "N", (ftnlen)1, (ftnlen)1)) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*kd < 0) { - *info = -6; - } else if (*ldab < *kd + 1) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLATBS", &i__1, (ftnlen)6); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Determine machine dependent parameters to control overflow. */ - - smlnum = dlamch_("Safe minimum", (ftnlen)12) / dlamch_("Precision", ( - ftnlen)9); - bignum = 1. / smlnum; - *scale = 1.; - - if (lsame_(normin, "N", (ftnlen)1, (ftnlen)1)) { - -/* Compute the 1-norm of each column, not including the diagonal. */ - - if (upper) { - -/* A is upper triangular. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__2 = *kd, i__3 = j - 1; - jlen = min(i__2,i__3); - cnorm[j] = dasum_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], & - c__1); -/* L10: */ - } - } else { - -/* A is lower triangular. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MIN */ - i__2 = *kd, i__3 = *n - j; - jlen = min(i__2,i__3); - if (jlen > 0) { - cnorm[j] = dasum_(&jlen, &ab[j * ab_dim1 + 2], &c__1); - } else { - cnorm[j] = 0.; - } -/* L20: */ - } - } - } - -/* Scale the column norms by TSCAL if the maximum element in CNORM is */ -/* greater than BIGNUM. */ - - imax = idamax_(n, &cnorm[1], &c__1); - tmax = cnorm[imax]; - if (tmax <= bignum) { - tscal = 1.; - } else { - tscal = 1. / (smlnum * tmax); - dscal_(n, &tscal, &cnorm[1], &c__1); - } - -/* Compute a bound on the computed solution vector to see if the */ -/* Level 2 BLAS routine DTBSV can be used. */ - - j = idamax_(n, &x[1], &c__1); - xmax = (d__1 = x[j], abs(d__1)); - xbnd = xmax; - if (notran) { - -/* Compute the growth in A * x = b. */ - - if (upper) { - jfirst = *n; - jlast = 1; - jinc = -1; - maind = *kd + 1; - } else { - jfirst = 1; - jlast = *n; - jinc = 1; - maind = 1; - } - - if (tscal != 1.) { - grow = 0.; - goto L50; - } - - if (nounit) { - -/* A is non-unit triangular. */ - -/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ -/* Initially, G(0) = max{x(i), i=1,...,n}. */ - - grow = 1. / max(xbnd,smlnum); - xbnd = grow; - i__1 = jlast; - i__2 = jinc; - for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L50; - } - -/* M(j) = G(j-1) / abs(A(j,j)) */ - - tjj = (d__1 = ab[maind + j * ab_dim1], abs(d__1)); -/* Computing MIN */ - d__1 = xbnd, d__2 = min(1.,tjj) * grow; - xbnd = min(d__1,d__2); - if (tjj + cnorm[j] >= smlnum) { - -/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ - - grow *= tjj / (tjj + cnorm[j]); - } else { - -/* G(j) could overflow, set GROW to 0. */ - - grow = 0.; - } -/* L30: */ - } - grow = xbnd; - } else { - -/* A is unit triangular. */ - -/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ - -/* Computing MIN */ - d__1 = 1., d__2 = 1. / max(xbnd,smlnum); - grow = min(d__1,d__2); - i__2 = jlast; - i__1 = jinc; - for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L50; - } - -/* G(j) = G(j-1)*( 1 + CNORM(j) ) */ - - grow *= 1. / (cnorm[j] + 1.); -/* L40: */ - } - } -L50: - - ; - } else { - -/* Compute the growth in A' * x = b. */ - - if (upper) { - jfirst = 1; - jlast = *n; - jinc = 1; - maind = *kd + 1; - } else { - jfirst = *n; - jlast = 1; - jinc = -1; - maind = 1; - } - - if (tscal != 1.) { - grow = 0.; - goto L80; - } - - if (nounit) { - -/* A is non-unit triangular. */ - -/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ -/* Initially, M(0) = max{x(i), i=1,...,n}. */ - - grow = 1. / max(xbnd,smlnum); - xbnd = grow; - i__1 = jlast; - i__2 = jinc; - for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L80; - } - -/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ - - xj = cnorm[j] + 1.; -/* Computing MIN */ - d__1 = grow, d__2 = xbnd / xj; - grow = min(d__1,d__2); - -/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ - - tjj = (d__1 = ab[maind + j * ab_dim1], abs(d__1)); - if (xj > tjj) { - xbnd *= tjj / xj; - } -/* L60: */ - } - grow = min(grow,xbnd); - } else { - -/* A is unit triangular. */ - -/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ - -/* Computing MIN */ - d__1 = 1., d__2 = 1. / max(xbnd,smlnum); - grow = min(d__1,d__2); - i__2 = jlast; - i__1 = jinc; - for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L80; - } - -/* G(j) = ( 1 + CNORM(j) )*G(j-1) */ - - xj = cnorm[j] + 1.; - grow /= xj; -/* L70: */ - } - } -L80: - ; - } - - if (grow * tscal > smlnum) { - -/* Use the Level 2 BLAS solve if the reciprocal of the bound on */ -/* elements of X is not too small. */ - - dtbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &x[1], &c__1, ( - ftnlen)1, (ftnlen)1, (ftnlen)1); - } else { - -/* Use a Level 1 BLAS solve, scaling intermediate results. */ - - if (xmax > bignum) { - -/* Scale X so that its components are less than or equal to */ -/* BIGNUM in absolute value. */ - - *scale = bignum / xmax; - dscal_(n, scale, &x[1], &c__1); - xmax = bignum; - } - - if (notran) { - -/* Solve A * x = b */ - - i__1 = jlast; - i__2 = jinc; - for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ - - xj = (d__1 = x[j], abs(d__1)); - if (nounit) { - tjjs = ab[maind + j * ab_dim1] * tscal; - } else { - tjjs = tscal; - if (tscal == 1.) { - goto L100; - } - } - tjj = abs(tjjs); - if (tjj > smlnum) { - -/* abs(A(j,j)) > SMLNUM: */ - - if (tjj < 1.) { - if (xj > tjj * bignum) { - -/* Scale x by 1/b(j). */ - - rec = 1. / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - x[j] /= tjjs; - xj = (d__1 = x[j], abs(d__1)); - } else if (tjj > 0.) { - -/* 0 < abs(A(j,j)) <= SMLNUM: */ - - if (xj > tjj * bignum) { - -/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ -/* to avoid overflow when dividing by A(j,j). */ - - rec = tjj * bignum / xj; - if (cnorm[j] > 1.) { - -/* Scale by 1/CNORM(j) to avoid overflow when */ -/* multiplying x(j) times column j. */ - - rec /= cnorm[j]; - } - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - x[j] /= tjjs; - xj = (d__1 = x[j], abs(d__1)); - } else { - -/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ -/* scale = 0, and compute a solution to A*x = 0. */ - - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - x[i__] = 0.; -/* L90: */ - } - x[j] = 1.; - xj = 1.; - *scale = 0.; - xmax = 0.; - } -L100: - -/* Scale x if necessary to avoid overflow when adding a */ -/* multiple of column j of A. */ - - if (xj > 1.) { - rec = 1. / xj; - if (cnorm[j] > (bignum - xmax) * rec) { - -/* Scale x by 1/(2*abs(x(j))). */ - - rec *= .5; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - } - } else if (xj * cnorm[j] > bignum - xmax) { - -/* Scale x by 1/2. */ - - dscal_(n, &c_b36, &x[1], &c__1); - *scale *= .5; - } - - if (upper) { - if (j > 1) { - -/* Compute the update */ -/* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - */ -/* x(j)* A(max(1,j-kd):j-1,j) */ - -/* Computing MIN */ - i__3 = *kd, i__4 = j - 1; - jlen = min(i__3,i__4); - d__1 = -x[j] * tscal; - daxpy_(&jlen, &d__1, &ab[*kd + 1 - jlen + j * ab_dim1] - , &c__1, &x[j - jlen], &c__1); - i__3 = j - 1; - i__ = idamax_(&i__3, &x[1], &c__1); - xmax = (d__1 = x[i__], abs(d__1)); - } - } else if (j < *n) { - -/* Compute the update */ -/* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) - */ -/* x(j) * A(j+1:min(j+kd,n),j) */ - -/* Computing MIN */ - i__3 = *kd, i__4 = *n - j; - jlen = min(i__3,i__4); - if (jlen > 0) { - d__1 = -x[j] * tscal; - daxpy_(&jlen, &d__1, &ab[j * ab_dim1 + 2], &c__1, &x[ - j + 1], &c__1); - } - i__3 = *n - j; - i__ = j + idamax_(&i__3, &x[j + 1], &c__1); - xmax = (d__1 = x[i__], abs(d__1)); - } -/* L110: */ - } - - } else { - -/* Solve A' * x = b */ - - i__2 = jlast; - i__1 = jinc; - for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ -/* k<>j */ - - xj = (d__1 = x[j], abs(d__1)); - uscal = tscal; - rec = 1. / max(xmax,1.); - if (cnorm[j] > (bignum - xj) * rec) { - -/* If x(j) could overflow, scale x by 1/(2*XMAX). */ - - rec *= .5; - if (nounit) { - tjjs = ab[maind + j * ab_dim1] * tscal; - } else { - tjjs = tscal; - } - tjj = abs(tjjs); - if (tjj > 1.) { - -/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ - -/* Computing MIN */ - d__1 = 1., d__2 = rec * tjj; - rec = min(d__1,d__2); - uscal /= tjjs; - } - if (rec < 1.) { - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - - sumj = 0.; - if (uscal == 1.) { - -/* If the scaling needed for A in the dot product is 1, */ -/* call DDOT to perform the dot product. */ - - if (upper) { -/* Computing MIN */ - i__3 = *kd, i__4 = j - 1; - jlen = min(i__3,i__4); - sumj = ddot_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], - &c__1, &x[j - jlen], &c__1); - } else { -/* Computing MIN */ - i__3 = *kd, i__4 = *n - j; - jlen = min(i__3,i__4); - if (jlen > 0) { - sumj = ddot_(&jlen, &ab[j * ab_dim1 + 2], &c__1, & - x[j + 1], &c__1); - } - } - } else { - -/* Otherwise, use in-line code for the dot product. */ - - if (upper) { -/* Computing MIN */ - i__3 = *kd, i__4 = j - 1; - jlen = min(i__3,i__4); - i__3 = jlen; - for (i__ = 1; i__ <= i__3; ++i__) { - sumj += ab[*kd + i__ - jlen + j * ab_dim1] * - uscal * x[j - jlen - 1 + i__]; -/* L120: */ - } - } else { -/* Computing MIN */ - i__3 = *kd, i__4 = *n - j; - jlen = min(i__3,i__4); - i__3 = jlen; - for (i__ = 1; i__ <= i__3; ++i__) { - sumj += ab[i__ + 1 + j * ab_dim1] * uscal * x[j + - i__]; -/* L130: */ - } - } - } - - if (uscal == tscal) { - -/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */ -/* was not used to scale the dotproduct. */ - - x[j] -= sumj; - xj = (d__1 = x[j], abs(d__1)); - if (nounit) { - -/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ - - tjjs = ab[maind + j * ab_dim1] * tscal; - } else { - tjjs = tscal; - if (tscal == 1.) { - goto L150; - } - } - tjj = abs(tjjs); - if (tjj > smlnum) { - -/* abs(A(j,j)) > SMLNUM: */ - - if (tjj < 1.) { - if (xj > tjj * bignum) { - -/* Scale X by 1/abs(x(j)). */ - - rec = 1. / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - x[j] /= tjjs; - } else if (tjj > 0.) { - -/* 0 < abs(A(j,j)) <= SMLNUM: */ - - if (xj > tjj * bignum) { - -/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ - - rec = tjj * bignum / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - x[j] /= tjjs; - } else { - -/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ -/* scale = 0, and compute a solution to A'*x = 0. */ - - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - x[i__] = 0.; -/* L140: */ - } - x[j] = 1.; - *scale = 0.; - xmax = 0.; - } -L150: - ; - } else { - -/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */ -/* product has already been divided by 1/A(j,j). */ - - x[j] = x[j] / tjjs - sumj; - } -/* Computing MAX */ - d__2 = xmax, d__3 = (d__1 = x[j], abs(d__1)); - xmax = max(d__2,d__3); -/* L160: */ - } - } - *scale /= tscal; - } - -/* Scale the column norms by 1/TSCAL for return. */ - - if (tscal != 1.) { - d__1 = 1. / tscal; - dscal_(n, &d__1, &cnorm[1], &c__1); - } - - return 0; - -/* End of DLATBS */ - -} /* dlatbs_ */ - diff --git a/ext/f2c_lapack/dlatrs.c b/ext/f2c_lapack/dlatrs.c deleted file mode 100644 index a08a0f09f..000000000 --- a/ext/f2c_lapack/dlatrs.c +++ /dev/null @@ -1,820 +0,0 @@ -/* dlatrs.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static doublereal c_b36 = .5; - -/* Subroutine */ int dlatrs_(char *uplo, char *trans, char *diag, char * - normin, integer *n, doublereal *a, integer *lda, doublereal *x, - doublereal *scale, doublereal *cnorm, integer *info, ftnlen uplo_len, - ftnlen trans_len, ftnlen diag_len, ftnlen normin_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - doublereal d__1, d__2, d__3; - - /* Local variables */ - static integer i__, j; - static doublereal xj, rec, tjj; - static integer jinc; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); - static doublereal xbnd; - static integer imax; - static doublereal tmax, tjjs, xmax, grow, sumj; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - extern logical lsame_(char *, char *, ftnlen, ftnlen); - static doublereal tscal, uscal; - extern doublereal dasum_(integer *, doublereal *, integer *); - static integer jlast; - extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - static logical upper; - extern /* Subroutine */ int dtrsv_(char *, char *, char *, integer *, - doublereal *, integer *, doublereal *, integer *, ftnlen, ftnlen, - ftnlen); - extern doublereal dlamch_(char *, ftnlen); - extern integer idamax_(integer *, doublereal *, integer *); - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - static doublereal bignum; - static logical notran; - static integer jfirst; - static doublereal smlnum; - static logical nounit; - - -/* -- LAPACK auxiliary routine (version 3.0) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ -/* Courant Institute, Argonne National Lab, and Rice University */ -/* June 30, 1992 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DLATRS solves one of the triangular systems */ - -/* A *x = s*b or A'*x = s*b */ - -/* with scaling to prevent overflow. Here A is an upper or lower */ -/* triangular matrix, A' denotes the transpose of A, x and b are */ -/* n-element vectors, and s is a scaling factor, usually less than */ -/* or equal to 1, chosen so that the components of x will be less than */ -/* the overflow threshold. If the unscaled problem will not cause */ -/* overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A */ -/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */ -/* non-trivial solution to A*x = 0 is returned. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the matrix A is upper or lower triangular. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the operation applied to A. */ -/* = 'N': Solve A * x = s*b (No transpose) */ -/* = 'T': Solve A'* x = s*b (Transpose) */ -/* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) */ - -/* DIAG (input) CHARACTER*1 */ -/* Specifies whether or not the matrix A is unit triangular. */ -/* = 'N': Non-unit triangular */ -/* = 'U': Unit triangular */ - -/* NORMIN (input) CHARACTER*1 */ -/* Specifies whether CNORM has been set or not. */ -/* = 'Y': CNORM contains the column norms on entry */ -/* = 'N': CNORM is not set on entry. On exit, the norms will */ -/* be computed and stored in CNORM. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The triangular matrix A. If UPLO = 'U', the leading n by n */ -/* upper triangular part of the array A contains the upper */ -/* triangular matrix, and the strictly lower triangular part of */ -/* A is not referenced. If UPLO = 'L', the leading n by n lower */ -/* triangular part of the array A contains the lower triangular */ -/* matrix, and the strictly upper triangular part of A is not */ -/* referenced. If DIAG = 'U', the diagonal elements of A are */ -/* also not referenced and are assumed to be 1. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max (1,N). */ - -/* X (input/output) DOUBLE PRECISION array, dimension (N) */ -/* On entry, the right hand side b of the triangular system. */ -/* On exit, X is overwritten by the solution vector x. */ - -/* SCALE (output) DOUBLE PRECISION */ -/* The scaling factor s for the triangular system */ -/* A * x = s*b or A'* x = s*b. */ -/* If SCALE = 0, the matrix A is singular or badly scaled, and */ -/* the vector x is an exact or approximate solution to A*x = 0. */ - -/* CNORM (input or output) DOUBLE PRECISION array, dimension (N) */ - -/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ -/* contains the norm of the off-diagonal part of the j-th column */ -/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ -/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ -/* must be greater than or equal to the 1-norm. */ - -/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ -/* returns the 1-norm of the offdiagonal part of the j-th column */ -/* of A. */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ - -/* Further Details */ -/* ======= ======= */ - -/* A rough bound on x is computed; if that is less than overflow, DTRSV */ -/* is called, otherwise, specific code is used which checks for possible */ -/* overflow or divide-by-zero at every operation. */ - -/* A columnwise scheme is used for solving A*x = b. The basic algorithm */ -/* if A is lower triangular is */ - -/* x[1:n] := b[1:n] */ -/* for j = 1, ..., n */ -/* x(j) := x(j) / A(j,j) */ -/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ -/* end */ - -/* Define bounds on the components of x after j iterations of the loop: */ -/* M(j) = bound on x[1:j] */ -/* G(j) = bound on x[j+1:n] */ -/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */ - -/* Then for iteration j+1 we have */ -/* M(j+1) <= G(j) / | A(j+1,j+1) | */ -/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ -/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ - -/* where CNORM(j+1) is greater than or equal to the infinity-norm of */ -/* column j+1 of A, not counting the diagonal. Hence */ - -/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ -/* 1<=i<=j */ -/* and */ - -/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ -/* 1<=i< j */ - -/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the */ -/* reciprocal of the largest M(j), j=1,..,n, is larger than */ -/* max(underflow, 1/overflow). */ - -/* The bound on x(j) is also used to determine when a step in the */ -/* columnwise method can be performed without fear of overflow. If */ -/* the computed bound is greater than a large constant, x is scaled to */ -/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ -/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ - -/* Similarly, a row-wise scheme is used to solve A'*x = b. The basic */ -/* algorithm for A upper triangular is */ - -/* for j = 1, ..., n */ -/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */ -/* end */ - -/* We simultaneously compute two bounds */ -/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */ -/* M(j) = bound on x(i), 1<=i<=j */ - -/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */ -/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ -/* Then the bound on x(j) is */ - -/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ - -/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ -/* 1<=i<=j */ - -/* and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater */ -/* than max(underflow, 1/overflow). */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --x; - --cnorm; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1); - notran = lsame_(trans, "N", (ftnlen)1, (ftnlen)1); - nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1); - -/* Test the input parameters. */ - - if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T", (ftnlen)1, (ftnlen)1) && ! - lsame_(trans, "C", (ftnlen)1, (ftnlen)1)) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { - *info = -3; - } else if (! lsame_(normin, "Y", (ftnlen)1, (ftnlen)1) && ! lsame_(normin, - "N", (ftnlen)1, (ftnlen)1)) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*lda < max(1,*n)) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DLATRS", &i__1, (ftnlen)6); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Determine machine dependent parameters to control overflow. */ - - smlnum = dlamch_("Safe minimum", (ftnlen)12) / dlamch_("Precision", ( - ftnlen)9); - bignum = 1. / smlnum; - *scale = 1.; - - if (lsame_(normin, "N", (ftnlen)1, (ftnlen)1)) { - -/* Compute the 1-norm of each column, not including the diagonal. */ - - if (upper) { - -/* A is upper triangular. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = j - 1; - cnorm[j] = dasum_(&i__2, &a[j * a_dim1 + 1], &c__1); -/* L10: */ - } - } else { - -/* A is lower triangular. */ - - i__1 = *n - 1; - for (j = 1; j <= i__1; ++j) { - i__2 = *n - j; - cnorm[j] = dasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1); -/* L20: */ - } - cnorm[*n] = 0.; - } - } - -/* Scale the column norms by TSCAL if the maximum element in CNORM is */ -/* greater than BIGNUM. */ - - imax = idamax_(n, &cnorm[1], &c__1); - tmax = cnorm[imax]; - if (tmax <= bignum) { - tscal = 1.; - } else { - tscal = 1. / (smlnum * tmax); - dscal_(n, &tscal, &cnorm[1], &c__1); - } - -/* Compute a bound on the computed solution vector to see if the */ -/* Level 2 BLAS routine DTRSV can be used. */ - - j = idamax_(n, &x[1], &c__1); - xmax = (d__1 = x[j], abs(d__1)); - xbnd = xmax; - if (notran) { - -/* Compute the growth in A * x = b. */ - - if (upper) { - jfirst = *n; - jlast = 1; - jinc = -1; - } else { - jfirst = 1; - jlast = *n; - jinc = 1; - } - - if (tscal != 1.) { - grow = 0.; - goto L50; - } - - if (nounit) { - -/* A is non-unit triangular. */ - -/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ -/* Initially, G(0) = max{x(i), i=1,...,n}. */ - - grow = 1. / max(xbnd,smlnum); - xbnd = grow; - i__1 = jlast; - i__2 = jinc; - for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L50; - } - -/* M(j) = G(j-1) / abs(A(j,j)) */ - - tjj = (d__1 = a[j + j * a_dim1], abs(d__1)); -/* Computing MIN */ - d__1 = xbnd, d__2 = min(1.,tjj) * grow; - xbnd = min(d__1,d__2); - if (tjj + cnorm[j] >= smlnum) { - -/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ - - grow *= tjj / (tjj + cnorm[j]); - } else { - -/* G(j) could overflow, set GROW to 0. */ - - grow = 0.; - } -/* L30: */ - } - grow = xbnd; - } else { - -/* A is unit triangular. */ - -/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ - -/* Computing MIN */ - d__1 = 1., d__2 = 1. / max(xbnd,smlnum); - grow = min(d__1,d__2); - i__2 = jlast; - i__1 = jinc; - for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L50; - } - -/* G(j) = G(j-1)*( 1 + CNORM(j) ) */ - - grow *= 1. / (cnorm[j] + 1.); -/* L40: */ - } - } -L50: - - ; - } else { - -/* Compute the growth in A' * x = b. */ - - if (upper) { - jfirst = 1; - jlast = *n; - jinc = 1; - } else { - jfirst = *n; - jlast = 1; - jinc = -1; - } - - if (tscal != 1.) { - grow = 0.; - goto L80; - } - - if (nounit) { - -/* A is non-unit triangular. */ - -/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ -/* Initially, M(0) = max{x(i), i=1,...,n}. */ - - grow = 1. / max(xbnd,smlnum); - xbnd = grow; - i__1 = jlast; - i__2 = jinc; - for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L80; - } - -/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ - - xj = cnorm[j] + 1.; -/* Computing MIN */ - d__1 = grow, d__2 = xbnd / xj; - grow = min(d__1,d__2); - -/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ - - tjj = (d__1 = a[j + j * a_dim1], abs(d__1)); - if (xj > tjj) { - xbnd *= tjj / xj; - } -/* L60: */ - } - grow = min(grow,xbnd); - } else { - -/* A is unit triangular. */ - -/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */ - -/* Computing MIN */ - d__1 = 1., d__2 = 1. / max(xbnd,smlnum); - grow = min(d__1,d__2); - i__2 = jlast; - i__1 = jinc; - for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Exit the loop if the growth factor is too small. */ - - if (grow <= smlnum) { - goto L80; - } - -/* G(j) = ( 1 + CNORM(j) )*G(j-1) */ - - xj = cnorm[j] + 1.; - grow /= xj; -/* L70: */ - } - } -L80: - ; - } - - if (grow * tscal > smlnum) { - -/* Use the Level 2 BLAS solve if the reciprocal of the bound on */ -/* elements of X is not too small. */ - - dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1, (ftnlen) - 1, (ftnlen)1, (ftnlen)1); - } else { - -/* Use a Level 1 BLAS solve, scaling intermediate results. */ - - if (xmax > bignum) { - -/* Scale X so that its components are less than or equal to */ -/* BIGNUM in absolute value. */ - - *scale = bignum / xmax; - dscal_(n, scale, &x[1], &c__1); - xmax = bignum; - } - - if (notran) { - -/* Solve A * x = b */ - - i__1 = jlast; - i__2 = jinc; - for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ - - xj = (d__1 = x[j], abs(d__1)); - if (nounit) { - tjjs = a[j + j * a_dim1] * tscal; - } else { - tjjs = tscal; - if (tscal == 1.) { - goto L100; - } - } - tjj = abs(tjjs); - if (tjj > smlnum) { - -/* abs(A(j,j)) > SMLNUM: */ - - if (tjj < 1.) { - if (xj > tjj * bignum) { - -/* Scale x by 1/b(j). */ - - rec = 1. / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - x[j] /= tjjs; - xj = (d__1 = x[j], abs(d__1)); - } else if (tjj > 0.) { - -/* 0 < abs(A(j,j)) <= SMLNUM: */ - - if (xj > tjj * bignum) { - -/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ -/* to avoid overflow when dividing by A(j,j). */ - - rec = tjj * bignum / xj; - if (cnorm[j] > 1.) { - -/* Scale by 1/CNORM(j) to avoid overflow when */ -/* multiplying x(j) times column j. */ - - rec /= cnorm[j]; - } - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - x[j] /= tjjs; - xj = (d__1 = x[j], abs(d__1)); - } else { - -/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ -/* scale = 0, and compute a solution to A*x = 0. */ - - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - x[i__] = 0.; -/* L90: */ - } - x[j] = 1.; - xj = 1.; - *scale = 0.; - xmax = 0.; - } -L100: - -/* Scale x if necessary to avoid overflow when adding a */ -/* multiple of column j of A. */ - - if (xj > 1.) { - rec = 1. / xj; - if (cnorm[j] > (bignum - xmax) * rec) { - -/* Scale x by 1/(2*abs(x(j))). */ - - rec *= .5; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - } - } else if (xj * cnorm[j] > bignum - xmax) { - -/* Scale x by 1/2. */ - - dscal_(n, &c_b36, &x[1], &c__1); - *scale *= .5; - } - - if (upper) { - if (j > 1) { - -/* Compute the update */ -/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */ - - i__3 = j - 1; - d__1 = -x[j] * tscal; - daxpy_(&i__3, &d__1, &a[j * a_dim1 + 1], &c__1, &x[1], - &c__1); - i__3 = j - 1; - i__ = idamax_(&i__3, &x[1], &c__1); - xmax = (d__1 = x[i__], abs(d__1)); - } - } else { - if (j < *n) { - -/* Compute the update */ -/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */ - - i__3 = *n - j; - d__1 = -x[j] * tscal; - daxpy_(&i__3, &d__1, &a[j + 1 + j * a_dim1], &c__1, & - x[j + 1], &c__1); - i__3 = *n - j; - i__ = j + idamax_(&i__3, &x[j + 1], &c__1); - xmax = (d__1 = x[i__], abs(d__1)); - } - } -/* L110: */ - } - - } else { - -/* Solve A' * x = b */ - - i__2 = jlast; - i__1 = jinc; - for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ -/* k<>j */ - - xj = (d__1 = x[j], abs(d__1)); - uscal = tscal; - rec = 1. / max(xmax,1.); - if (cnorm[j] > (bignum - xj) * rec) { - -/* If x(j) could overflow, scale x by 1/(2*XMAX). */ - - rec *= .5; - if (nounit) { - tjjs = a[j + j * a_dim1] * tscal; - } else { - tjjs = tscal; - } - tjj = abs(tjjs); - if (tjj > 1.) { - -/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ - -/* Computing MIN */ - d__1 = 1., d__2 = rec * tjj; - rec = min(d__1,d__2); - uscal /= tjjs; - } - if (rec < 1.) { - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - - sumj = 0.; - if (uscal == 1.) { - -/* If the scaling needed for A in the dot product is 1, */ -/* call DDOT to perform the dot product. */ - - if (upper) { - i__3 = j - 1; - sumj = ddot_(&i__3, &a[j * a_dim1 + 1], &c__1, &x[1], - &c__1); - } else if (j < *n) { - i__3 = *n - j; - sumj = ddot_(&i__3, &a[j + 1 + j * a_dim1], &c__1, &x[ - j + 1], &c__1); - } - } else { - -/* Otherwise, use in-line code for the dot product. */ - - if (upper) { - i__3 = j - 1; - for (i__ = 1; i__ <= i__3; ++i__) { - sumj += a[i__ + j * a_dim1] * uscal * x[i__]; -/* L120: */ - } - } else if (j < *n) { - i__3 = *n; - for (i__ = j + 1; i__ <= i__3; ++i__) { - sumj += a[i__ + j * a_dim1] * uscal * x[i__]; -/* L130: */ - } - } - } - - if (uscal == tscal) { - -/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */ -/* was not used to scale the dotproduct. */ - - x[j] -= sumj; - xj = (d__1 = x[j], abs(d__1)); - if (nounit) { - tjjs = a[j + j * a_dim1] * tscal; - } else { - tjjs = tscal; - if (tscal == 1.) { - goto L150; - } - } - -/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ - - tjj = abs(tjjs); - if (tjj > smlnum) { - -/* abs(A(j,j)) > SMLNUM: */ - - if (tjj < 1.) { - if (xj > tjj * bignum) { - -/* Scale X by 1/abs(x(j)). */ - - rec = 1. / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - } - x[j] /= tjjs; - } else if (tjj > 0.) { - -/* 0 < abs(A(j,j)) <= SMLNUM: */ - - if (xj > tjj * bignum) { - -/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ - - rec = tjj * bignum / xj; - dscal_(n, &rec, &x[1], &c__1); - *scale *= rec; - xmax *= rec; - } - x[j] /= tjjs; - } else { - -/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ -/* scale = 0, and compute a solution to A'*x = 0. */ - - i__3 = *n; - for (i__ = 1; i__ <= i__3; ++i__) { - x[i__] = 0.; -/* L140: */ - } - x[j] = 1.; - *scale = 0.; - xmax = 0.; - } -L150: - ; - } else { - -/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */ -/* product has already been divided by 1/A(j,j). */ - - x[j] = x[j] / tjjs - sumj; - } -/* Computing MAX */ - d__2 = xmax, d__3 = (d__1 = x[j], abs(d__1)); - xmax = max(d__2,d__3); -/* L160: */ - } - } - *scale /= tscal; - } - -/* Scale the column norms by 1/TSCAL for return. */ - - if (tscal != 1.) { - d__1 = 1. / tscal; - dscal_(n, &d__1, &cnorm[1], &c__1); - } - - return 0; - -/* End of DLATRS */ - -} /* dlatrs_ */ - diff --git a/ext/f2c_lapack/dorg2r.c b/ext/f2c_lapack/dorg2r.c deleted file mode 100644 index 623be03f5..000000000 --- a/ext/f2c_lapack/dorg2r.c +++ /dev/null @@ -1,160 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dorg2r_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - February 29, 1992 - - - Purpose - ======= - - DORG2R generates an m by n real matrix Q with orthonormal columns, - which is defined as the first n columns of a product of k elementary - reflectors of order m - - Q = H(1) H(2) . . . H(k) - - as returned by DGEQRF. - - Arguments - ========= - - M (input) INTEGER - The number of rows of the matrix Q. M >= 0. - - N (input) INTEGER - The number of columns of the matrix Q. M >= N >= 0. - - K (input) INTEGER - The number of elementary reflectors whose product defines the - matrix Q. N >= K >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the i-th column must contain the vector which - defines the elementary reflector H(i), for i = 1,2,...,k, as - returned by DGEQRF in the first k columns of its array - argument A. - On exit, the m-by-n matrix Q. - - LDA (input) INTEGER - The first dimension of the array A. LDA >= max(1,M). - - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary - reflector H(i), as returned by DGEQRF. - - WORK (workspace) DOUBLE PRECISION array, dimension (N) - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument has an illegal value - - ===================================================================== - - - Test the input arguments - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - doublereal d__1; - /* Local variables */ - static integer i__, j, l; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dlarf_(char *, integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, doublereal *), xerbla_(char *, integer *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < 0 || *n > *m) { - *info = -2; - } else if (*k < 0 || *k > *n) { - *info = -3; - } else if (*lda < max(1,*m)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORG2R", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n <= 0) { - return 0; - } - -/* Initialise columns k+1:n to columns of the unit matrix */ - - i__1 = *n; - for (j = *k + 1; j <= i__1; ++j) { - i__2 = *m; - for (l = 1; l <= i__2; ++l) { - a_ref(l, j) = 0.; -/* L10: */ - } - a_ref(j, j) = 1.; -/* L20: */ - } - - for (i__ = *k; i__ >= 1; --i__) { - -/* Apply H(i) to A(i:m,i:n) from the left */ - - if (i__ < *n) { - a_ref(i__, i__) = 1.; - i__1 = *m - i__ + 1; - i__2 = *n - i__; - dlarf_("Left", &i__1, &i__2, &a_ref(i__, i__), &c__1, &tau[i__], & - a_ref(i__, i__ + 1), lda, &work[1]); - } - if (i__ < *m) { - i__1 = *m - i__; - d__1 = -tau[i__]; - dscal_(&i__1, &d__1, &a_ref(i__ + 1, i__), &c__1); - } - a_ref(i__, i__) = 1. - tau[i__]; - -/* Set A(1:i-1,i) to zero */ - - i__1 = i__ - 1; - for (l = 1; l <= i__1; ++l) { - a_ref(l, i__) = 0.; -/* L30: */ - } -/* L40: */ - } - return 0; - -/* End of DORG2R */ - -} /* dorg2r_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dorgbr.c b/ext/f2c_lapack/dorgbr.c deleted file mode 100644 index f75621512..000000000 --- a/ext/f2c_lapack/dorgbr.c +++ /dev/null @@ -1,285 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dorgbr_(char *vect, integer *m, integer *n, integer *k, - doublereal *a, integer *lda, doublereal *tau, doublereal *work, - integer *lwork, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1999 - - - Purpose - ======= - - DORGBR generates one of the real orthogonal matrices Q or P**T - determined by DGEBRD when reducing a real matrix A to bidiagonal - form: A = Q * B * P**T. Q and P**T are defined as products of - elementary reflectors H(i) or G(i) respectively. - - If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q - is of order M: - if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n - columns of Q, where m >= n >= k; - if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an - M-by-M matrix. - - If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T - is of order N: - if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m - rows of P**T, where n >= m >= k; - if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as - an N-by-N matrix. - - Arguments - ========= - - VECT (input) CHARACTER*1 - Specifies whether the matrix Q or the matrix P**T is - required, as defined in the transformation applied by DGEBRD: - = 'Q': generate Q; - = 'P': generate P**T. - - M (input) INTEGER - The number of rows of the matrix Q or P**T to be returned. - M >= 0. - - N (input) INTEGER - The number of columns of the matrix Q or P**T to be returned. - N >= 0. - If VECT = 'Q', M >= N >= min(M,K); - if VECT = 'P', N >= M >= min(N,K). - - K (input) INTEGER - If VECT = 'Q', the number of columns in the original M-by-K - matrix reduced by DGEBRD. - If VECT = 'P', the number of rows in the original K-by-N - matrix reduced by DGEBRD. - K >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the vectors which define the elementary reflectors, - as returned by DGEBRD. - On exit, the M-by-N matrix Q or P**T. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,M). - - TAU (input) DOUBLE PRECISION array, dimension - (min(M,K)) if VECT = 'Q' - (min(N,K)) if VECT = 'P' - TAU(i) must contain the scalar factor of the elementary - reflector H(i) or G(i), which determines Q or P**T, as - returned by DGEBRD in its array argument TAUQ or TAUP. - - WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - - LWORK (input) INTEGER - The dimension of the array WORK. LWORK >= max(1,min(M,N)). - For optimum performance LWORK >= min(M,N)*NB, where NB - is the optimal blocksize. - - If LWORK = -1, then a workspace query is assumed; the routine - only calculates the optimal size of the WORK array, returns - this value as the first entry of the WORK array, and no error - message related to LWORK is issued by XERBLA. - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - - ===================================================================== - - - Test the input arguments - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static integer c_n1 = -1; - - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - /* Local variables */ - static integer i__, j; - extern logical lsame_(char *, char *); - static integer iinfo; - static logical wantq; - static integer nb, mn; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int dorglq_(integer *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - integer *), dorgqr_(integer *, integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, integer *); - static integer lwkopt; - static logical lquery; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - wantq = lsame_(vect, "Q"); - mn = min(*m,*n); - lquery = *lwork == -1; - if (! wantq && ! lsame_(vect, "P")) { - *info = -1; - } else if (*m < 0) { - *info = -2; - } else if (*n < 0 || wantq && (*n > *m || *n < min(*m,*k)) || ! wantq && ( - *m > *n || *m < min(*n,*k))) { - *info = -3; - } else if (*k < 0) { - *info = -4; - } else if (*lda < max(1,*m)) { - *info = -6; - } else if (*lwork < max(1,mn) && ! lquery) { - *info = -9; - } - - if (*info == 0) { - if (wantq) { - nb = ilaenv_(&c__1, "DORGQR", " ", m, n, k, &c_n1, (ftnlen)6, ( - ftnlen)1); - } else { - nb = ilaenv_(&c__1, "DORGLQ", " ", m, n, k, &c_n1, (ftnlen)6, ( - ftnlen)1); - } - lwkopt = max(1,mn) * nb; - work[1] = (doublereal) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGBR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0) { - work[1] = 1.; - return 0; - } - - if (wantq) { - -/* Form Q, determined by a call to DGEBRD to reduce an m-by-k - matrix */ - - if (*m >= *k) { - -/* If m >= k, assume m >= n >= k */ - - dorgqr_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & - iinfo); - - } else { - -/* If m < k, assume m = n - - Shift the vectors which define the elementary reflectors one - column to the right, and set the first row and column of Q - to those of the unit matrix */ - - for (j = *m; j >= 2; --j) { - a_ref(1, j) = 0.; - i__1 = *m; - for (i__ = j + 1; i__ <= i__1; ++i__) { - a_ref(i__, j) = a_ref(i__, j - 1); -/* L10: */ - } -/* L20: */ - } - a_ref(1, 1) = 1.; - i__1 = *m; - for (i__ = 2; i__ <= i__1; ++i__) { - a_ref(i__, 1) = 0.; -/* L30: */ - } - if (*m > 1) { - -/* Form Q(2:m,2:m) */ - - i__1 = *m - 1; - i__2 = *m - 1; - i__3 = *m - 1; - dorgqr_(&i__1, &i__2, &i__3, &a_ref(2, 2), lda, &tau[1], & - work[1], lwork, &iinfo); - } - } - } else { - -/* Form P', determined by a call to DGEBRD to reduce a k-by-n - matrix */ - - if (*k < *n) { - -/* If k < n, assume k <= m <= n */ - - dorglq_(m, n, k, &a[a_offset], lda, &tau[1], &work[1], lwork, & - iinfo); - - } else { - -/* If k >= n, assume m = n - - Shift the vectors which define the elementary reflectors one - row downward, and set the first row and column of P' to - those of the unit matrix */ - - a_ref(1, 1) = 1.; - i__1 = *n; - for (i__ = 2; i__ <= i__1; ++i__) { - a_ref(i__, 1) = 0.; -/* L40: */ - } - i__1 = *n; - for (j = 2; j <= i__1; ++j) { - for (i__ = j - 1; i__ >= 2; --i__) { - a_ref(i__, j) = a_ref(i__ - 1, j); -/* L50: */ - } - a_ref(1, j) = 0.; -/* L60: */ - } - if (*n > 1) { - -/* Form P'(2:n,2:n) */ - - i__1 = *n - 1; - i__2 = *n - 1; - i__3 = *n - 1; - dorglq_(&i__1, &i__2, &i__3, &a_ref(2, 2), lda, &tau[1], & - work[1], lwork, &iinfo); - } - } - } - work[1] = (doublereal) lwkopt; - return 0; - -/* End of DORGBR */ - -} /* dorgbr_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dorgl2.c b/ext/f2c_lapack/dorgl2.c deleted file mode 100644 index 84defe579..000000000 --- a/ext/f2c_lapack/dorgl2.c +++ /dev/null @@ -1,160 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dorgl2_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1999 - - - Purpose - ======= - - DORGL2 generates an m by n real matrix Q with orthonormal rows, - which is defined as the first m rows of a product of k elementary - reflectors of order n - - Q = H(k) . . . H(2) H(1) - - as returned by DGELQF. - - Arguments - ========= - - M (input) INTEGER - The number of rows of the matrix Q. M >= 0. - - N (input) INTEGER - The number of columns of the matrix Q. N >= M. - - K (input) INTEGER - The number of elementary reflectors whose product defines the - matrix Q. M >= K >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the i-th row must contain the vector which defines - the elementary reflector H(i), for i = 1,2,...,k, as returned - by DGELQF in the first k rows of its array argument A. - On exit, the m-by-n matrix Q. - - LDA (input) INTEGER - The first dimension of the array A. LDA >= max(1,M). - - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary - reflector H(i), as returned by DGELQF. - - WORK (workspace) DOUBLE PRECISION array, dimension (M) - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument has an illegal value - - ===================================================================== - - - Test the input arguments - - Parameter adjustments */ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - doublereal d__1; - /* Local variables */ - static integer i__, j, l; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dlarf_(char *, integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, doublereal *), xerbla_(char *, integer *); -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - if (*m < 0) { - *info = -1; - } else if (*n < *m) { - *info = -2; - } else if (*k < 0 || *k > *m) { - *info = -3; - } else if (*lda < max(1,*m)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGL2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m <= 0) { - return 0; - } - - if (*k < *m) { - -/* Initialise rows k+1:m to rows of the unit matrix */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (l = *k + 1; l <= i__2; ++l) { - a_ref(l, j) = 0.; -/* L10: */ - } - if (j > *k && j <= *m) { - a_ref(j, j) = 1.; - } -/* L20: */ - } - } - - for (i__ = *k; i__ >= 1; --i__) { - -/* Apply H(i) to A(i:m,i:n) from the right */ - - if (i__ < *n) { - if (i__ < *m) { - a_ref(i__, i__) = 1.; - i__1 = *m - i__; - i__2 = *n - i__ + 1; - dlarf_("Right", &i__1, &i__2, &a_ref(i__, i__), lda, &tau[i__] - , &a_ref(i__ + 1, i__), lda, &work[1]); - } - i__1 = *n - i__; - d__1 = -tau[i__]; - dscal_(&i__1, &d__1, &a_ref(i__, i__ + 1), lda); - } - a_ref(i__, i__) = 1. - tau[i__]; - -/* Set A(i,1:i-1) to zero */ - - i__1 = i__ - 1; - for (l = 1; l <= i__1; ++l) { - a_ref(i__, l) = 0.; -/* L30: */ - } -/* L40: */ - } - return 0; - -/* End of DORGL2 */ - -} /* dorgl2_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dorglq.c b/ext/f2c_lapack/dorglq.c deleted file mode 100644 index 63c5655c2..000000000 --- a/ext/f2c_lapack/dorglq.c +++ /dev/null @@ -1,269 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dorglq_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, - integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1999 - - - Purpose - ======= - - DORGLQ generates an M-by-N real matrix Q with orthonormal rows, - which is defined as the first M rows of a product of K elementary - reflectors of order N - - Q = H(k) . . . H(2) H(1) - - as returned by DGELQF. - - Arguments - ========= - - M (input) INTEGER - The number of rows of the matrix Q. M >= 0. - - N (input) INTEGER - The number of columns of the matrix Q. N >= M. - - K (input) INTEGER - The number of elementary reflectors whose product defines the - matrix Q. M >= K >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the i-th row must contain the vector which defines - the elementary reflector H(i), for i = 1,2,...,k, as returned - by DGELQF in the first k rows of its array argument A. - On exit, the M-by-N matrix Q. - - LDA (input) INTEGER - The first dimension of the array A. LDA >= max(1,M). - - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary - reflector H(i), as returned by DGELQF. - - WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - - LWORK (input) INTEGER - The dimension of the array WORK. LWORK >= max(1,M). - For optimum performance LWORK >= M*NB, where NB is - the optimal blocksize. - - If LWORK = -1, then a workspace query is assumed; the routine - only calculates the optimal size of the WORK array, returns - this value as the first entry of the WORK array, and no error - message related to LWORK is issued by XERBLA. - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument has an illegal value - - ===================================================================== - - - Test the input arguments - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static integer c_n1 = -1; - static integer c__3 = 3; - static integer c__2 = 2; - - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - /* Local variables */ - static integer i__, j, l, nbmin, iinfo; - extern /* Subroutine */ int dorgl2_(integer *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *); - static integer ib, nb, ki, kk; - extern /* Subroutine */ int dlarfb_(char *, char *, char *, char *, - integer *, integer *, integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *); - static integer nx; - extern /* Subroutine */ int dlarft_(char *, char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - static integer ldwork, lwkopt; - static logical lquery; - static integer iws; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - nb = ilaenv_(&c__1, "DORGLQ", " ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); - lwkopt = max(1,*m) * nb; - work[1] = (doublereal) lwkopt; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < *m) { - *info = -2; - } else if (*k < 0 || *k > *m) { - *info = -3; - } else if (*lda < max(1,*m)) { - *info = -5; - } else if (*lwork < max(1,*m) && ! lquery) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGLQ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m <= 0) { - work[1] = 1.; - return 0; - } - - nbmin = 2; - nx = 0; - iws = *m; - if (nb > 1 && nb < *k) { - -/* Determine when to cross over from blocked to unblocked code. - - Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, "DORGLQ", " ", m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)1); - nx = max(i__1,i__2); - if (nx < *k) { - -/* Determine if workspace is large enough for blocked code. */ - - ldwork = *m; - iws = ldwork * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: reduce NB and - determine the minimum value of NB. */ - - nb = *lwork / ldwork; -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DORGLQ", " ", m, n, k, &c_n1, - (ftnlen)6, (ftnlen)1); - nbmin = max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < *k && nx < *k) { - -/* Use blocked code after the last block. - The first kk rows are handled by the block method. */ - - ki = (*k - nx - 1) / nb * nb; -/* Computing MIN */ - i__1 = *k, i__2 = ki + nb; - kk = min(i__1,i__2); - -/* Set A(kk+1:m,1:kk) to zero. */ - - i__1 = kk; - for (j = 1; j <= i__1; ++j) { - i__2 = *m; - for (i__ = kk + 1; i__ <= i__2; ++i__) { - a_ref(i__, j) = 0.; -/* L10: */ - } -/* L20: */ - } - } else { - kk = 0; - } - -/* Use unblocked code for the last or only block. */ - - if (kk < *m) { - i__1 = *m - kk; - i__2 = *n - kk; - i__3 = *k - kk; - dorgl2_(&i__1, &i__2, &i__3, &a_ref(kk + 1, kk + 1), lda, &tau[kk + 1] - , &work[1], &iinfo); - } - - if (kk > 0) { - -/* Use blocked code */ - - i__1 = -nb; - for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { -/* Computing MIN */ - i__2 = nb, i__3 = *k - i__ + 1; - ib = min(i__2,i__3); - if (i__ + ib <= *m) { - -/* Form the triangular factor of the block reflector - H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__2 = *n - i__ + 1; - dlarft_("Forward", "Rowwise", &i__2, &ib, &a_ref(i__, i__), - lda, &tau[i__], &work[1], &ldwork); - -/* Apply H' to A(i+ib:m,i:n) from the right */ - - i__2 = *m - i__ - ib + 1; - i__3 = *n - i__ + 1; - dlarfb_("Right", "Transpose", "Forward", "Rowwise", &i__2, & - i__3, &ib, &a_ref(i__, i__), lda, &work[1], &ldwork, & - a_ref(i__ + ib, i__), lda, &work[ib + 1], &ldwork); - } - -/* Apply H' to columns i:n of current block */ - - i__2 = *n - i__ + 1; - dorgl2_(&ib, &i__2, &ib, &a_ref(i__, i__), lda, &tau[i__], &work[ - 1], &iinfo); - -/* Set columns 1:i-1 of current block to zero */ - - i__2 = i__ - 1; - for (j = 1; j <= i__2; ++j) { - i__3 = i__ + ib - 1; - for (l = i__; l <= i__3; ++l) { - a_ref(l, j) = 0.; -/* L30: */ - } -/* L40: */ - } -/* L50: */ - } - } - - work[1] = (doublereal) iws; - return 0; - -/* End of DORGLQ */ - -} /* dorglq_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dorgqr.c b/ext/f2c_lapack/dorgqr.c deleted file mode 100644 index 037649b7b..000000000 --- a/ext/f2c_lapack/dorgqr.c +++ /dev/null @@ -1,271 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dorgqr_(integer *m, integer *n, integer *k, doublereal * - a, integer *lda, doublereal *tau, doublereal *work, integer *lwork, - integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1999 - - - Purpose - ======= - - DORGQR generates an M-by-N real matrix Q with orthonormal columns, - which is defined as the first N columns of a product of K elementary - reflectors of order M - - Q = H(1) H(2) . . . H(k) - - as returned by DGEQRF. - - Arguments - ========= - - M (input) INTEGER - The number of rows of the matrix Q. M >= 0. - - N (input) INTEGER - The number of columns of the matrix Q. M >= N >= 0. - - K (input) INTEGER - The number of elementary reflectors whose product defines the - matrix Q. N >= K >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the i-th column must contain the vector which - defines the elementary reflector H(i), for i = 1,2,...,k, as - returned by DGEQRF in the first k columns of its array - argument A. - On exit, the M-by-N matrix Q. - - LDA (input) INTEGER - The first dimension of the array A. LDA >= max(1,M). - - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary - reflector H(i), as returned by DGEQRF. - - WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - - LWORK (input) INTEGER - The dimension of the array WORK. LWORK >= max(1,N). - For optimum performance LWORK >= N*NB, where NB is the - optimal blocksize. - - If LWORK = -1, then a workspace query is assumed; the routine - only calculates the optimal size of the WORK array, returns - this value as the first entry of the WORK array, and no error - message related to LWORK is issued by XERBLA. - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument has an illegal value - - ===================================================================== - - - Test the input arguments - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static integer c_n1 = -1; - static integer c__3 = 3; - static integer c__2 = 2; - - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - /* Local variables */ - static integer i__, j, l, nbmin, iinfo; - extern /* Subroutine */ int dorg2r_(integer *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *); - static integer ib, nb, ki, kk; - extern /* Subroutine */ int dlarfb_(char *, char *, char *, char *, - integer *, integer *, integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *); - static integer nx; - extern /* Subroutine */ int dlarft_(char *, char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - static integer ldwork, lwkopt; - static logical lquery; - static integer iws; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --tau; - --work; - - /* Function Body */ - *info = 0; - nb = ilaenv_(&c__1, "DORGQR", " ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1); - lwkopt = max(1,*n) * nb; - work[1] = (doublereal) lwkopt; - lquery = *lwork == -1; - if (*m < 0) { - *info = -1; - } else if (*n < 0 || *n > *m) { - *info = -2; - } else if (*k < 0 || *k > *n) { - *info = -3; - } else if (*lda < max(1,*m)) { - *info = -5; - } else if (*lwork < max(1,*n) && ! lquery) { - *info = -8; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORGQR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*n <= 0) { - work[1] = 1.; - return 0; - } - - nbmin = 2; - nx = 0; - iws = *n; - if (nb > 1 && nb < *k) { - -/* Determine when to cross over from blocked to unblocked code. - - Computing MAX */ - i__1 = 0, i__2 = ilaenv_(&c__3, "DORGQR", " ", m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)1); - nx = max(i__1,i__2); - if (nx < *k) { - -/* Determine if workspace is large enough for blocked code. */ - - ldwork = *n; - iws = ldwork * nb; - if (*lwork < iws) { - -/* Not enough workspace to use optimal NB: reduce NB and - determine the minimum value of NB. */ - - nb = *lwork / ldwork; -/* Computing MAX */ - i__1 = 2, i__2 = ilaenv_(&c__2, "DORGQR", " ", m, n, k, &c_n1, - (ftnlen)6, (ftnlen)1); - nbmin = max(i__1,i__2); - } - } - } - - if (nb >= nbmin && nb < *k && nx < *k) { - -/* Use blocked code after the last block. - The first kk columns are handled by the block method. */ - - ki = (*k - nx - 1) / nb * nb; -/* Computing MIN */ - i__1 = *k, i__2 = ki + nb; - kk = min(i__1,i__2); - -/* Set A(1:kk,kk+1:n) to zero. */ - - i__1 = *n; - for (j = kk + 1; j <= i__1; ++j) { - i__2 = kk; - for (i__ = 1; i__ <= i__2; ++i__) { - a_ref(i__, j) = 0.; -/* L10: */ - } -/* L20: */ - } - } else { - kk = 0; - } - -/* Use unblocked code for the last or only block. */ - - if (kk < *n) { - i__1 = *m - kk; - i__2 = *n - kk; - i__3 = *k - kk; - dorg2r_(&i__1, &i__2, &i__3, &a_ref(kk + 1, kk + 1), lda, &tau[kk + 1] - , &work[1], &iinfo); - } - - if (kk > 0) { - -/* Use blocked code */ - - i__1 = -nb; - for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { -/* Computing MIN */ - i__2 = nb, i__3 = *k - i__ + 1; - ib = min(i__2,i__3); - if (i__ + ib <= *n) { - -/* Form the triangular factor of the block reflector - H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__2 = *m - i__ + 1; - dlarft_("Forward", "Columnwise", &i__2, &ib, &a_ref(i__, i__), - lda, &tau[i__], &work[1], &ldwork); - -/* Apply H to A(i:m,i+ib:n) from the left */ - - i__2 = *m - i__ + 1; - i__3 = *n - i__ - ib + 1; - dlarfb_("Left", "No transpose", "Forward", "Columnwise", & - i__2, &i__3, &ib, &a_ref(i__, i__), lda, &work[1], & - ldwork, &a_ref(i__, i__ + ib), lda, &work[ib + 1], & - ldwork); - } - -/* Apply H to rows i:m of current block */ - - i__2 = *m - i__ + 1; - dorg2r_(&i__2, &ib, &ib, &a_ref(i__, i__), lda, &tau[i__], &work[ - 1], &iinfo); - -/* Set rows 1:i-1 of current block to zero */ - - i__2 = i__ + ib - 1; - for (j = i__; j <= i__2; ++j) { - i__3 = i__ - 1; - for (l = 1; l <= i__3; ++l) { - a_ref(l, j) = 0.; -/* L30: */ - } -/* L40: */ - } -/* L50: */ - } - } - - work[1] = (doublereal) iws; - return 0; - -/* End of DORGQR */ - -} /* dorgqr_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dorm2r.c b/ext/f2c_lapack/dorm2r.c deleted file mode 100644 index 3ec082e9d..000000000 --- a/ext/f2c_lapack/dorm2r.c +++ /dev/null @@ -1,221 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dorm2r_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - February 29, 1992 - - - Purpose - ======= - - DORM2R overwrites the general real m by n matrix C with - - Q * C if SIDE = 'L' and TRANS = 'N', or - - Q'* C if SIDE = 'L' and TRANS = 'T', or - - C * Q if SIDE = 'R' and TRANS = 'N', or - - C * Q' if SIDE = 'R' and TRANS = 'T', - - where Q is a real orthogonal matrix defined as the product of k - elementary reflectors - - Q = H(1) H(2) . . . H(k) - - as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n - if SIDE = 'R'. - - Arguments - ========= - - SIDE (input) CHARACTER*1 - = 'L': apply Q or Q' from the Left - = 'R': apply Q or Q' from the Right - - TRANS (input) CHARACTER*1 - = 'N': apply Q (No transpose) - = 'T': apply Q' (Transpose) - - M (input) INTEGER - The number of rows of the matrix C. M >= 0. - - N (input) INTEGER - The number of columns of the matrix C. N >= 0. - - K (input) INTEGER - The number of elementary reflectors whose product defines - the matrix Q. - If SIDE = 'L', M >= K >= 0; - if SIDE = 'R', N >= K >= 0. - - A (input) DOUBLE PRECISION array, dimension (LDA,K) - The i-th column must contain the vector which defines the - elementary reflector H(i), for i = 1,2,...,k, as returned by - DGEQRF in the first k columns of its array argument A. - A is modified by the routine but restored on exit. - - LDA (input) INTEGER - The leading dimension of the array A. - If SIDE = 'L', LDA >= max(1,M); - if SIDE = 'R', LDA >= max(1,N). - - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary - reflector H(i), as returned by DGEQRF. - - C (input/output) DOUBLE PRECISION array, dimension (LDC,N) - On entry, the m by n matrix C. - On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. - - LDC (input) INTEGER - The leading dimension of the array C. LDC >= max(1,M). - - WORK (workspace) DOUBLE PRECISION array, dimension - (N) if SIDE = 'L', - (M) if SIDE = 'R' - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - - ===================================================================== - - - Test the input arguments - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; - /* Local variables */ - static logical left; - static integer i__; - extern /* Subroutine */ int dlarf_(char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - doublereal *); - extern logical lsame_(char *, char *); - static integer i1, i2, i3, ic, jc, mi, ni, nq; - extern /* Subroutine */ int xerbla_(char *, integer *); - static logical notran; - static doublereal aii; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - -/* NQ is the order of Q */ - - if (left) { - nq = *m; - } else { - nq = *n; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < max(1,nq)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORM2R", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - return 0; - } - - if (left && ! notran || ! left && notran) { - i1 = 1; - i2 = *k; - i3 = 1; - } else { - i1 = *k; - i2 = 1; - i3 = -1; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { - -/* H(i) is applied to C(i:m,1:n) */ - - mi = *m - i__ + 1; - ic = i__; - } else { - -/* H(i) is applied to C(1:m,i:n) */ - - ni = *n - i__ + 1; - jc = i__; - } - -/* Apply H(i) */ - - aii = a_ref(i__, i__); - a_ref(i__, i__) = 1.; - dlarf_(side, &mi, &ni, &a_ref(i__, i__), &c__1, &tau[i__], &c___ref( - ic, jc), ldc, &work[1]); - a_ref(i__, i__) = aii; -/* L10: */ - } - return 0; - -/* End of DORM2R */ - -} /* dorm2r_ */ - -#undef c___ref -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dormbr.c b/ext/f2c_lapack/dormbr.c deleted file mode 100644 index 8aff57316..000000000 --- a/ext/f2c_lapack/dormbr.c +++ /dev/null @@ -1,348 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dormbr_(char *vect, char *side, char *trans, integer *m, - integer *n, integer *k, doublereal *a, integer *lda, doublereal *tau, - doublereal *c__, integer *ldc, doublereal *work, integer *lwork, - integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1999 - - - Purpose - ======= - - If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C - with - SIDE = 'L' SIDE = 'R' - TRANS = 'N': Q * C C * Q - TRANS = 'T': Q**T * C C * Q**T - - If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C - with - SIDE = 'L' SIDE = 'R' - TRANS = 'N': P * C C * P - TRANS = 'T': P**T * C C * P**T - - Here Q and P**T are the orthogonal matrices determined by DGEBRD when - reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and - P**T are defined as products of elementary reflectors H(i) and G(i) - respectively. - - Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the - order of the orthogonal matrix Q or P**T that is applied. - - If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: - if nq >= k, Q = H(1) H(2) . . . H(k); - if nq < k, Q = H(1) H(2) . . . H(nq-1). - - If VECT = 'P', A is assumed to have been a K-by-NQ matrix: - if k < nq, P = G(1) G(2) . . . G(k); - if k >= nq, P = G(1) G(2) . . . G(nq-1). - - Arguments - ========= - - VECT (input) CHARACTER*1 - = 'Q': apply Q or Q**T; - = 'P': apply P or P**T. - - SIDE (input) CHARACTER*1 - = 'L': apply Q, Q**T, P or P**T from the Left; - = 'R': apply Q, Q**T, P or P**T from the Right. - - TRANS (input) CHARACTER*1 - = 'N': No transpose, apply Q or P; - = 'T': Transpose, apply Q**T or P**T. - - M (input) INTEGER - The number of rows of the matrix C. M >= 0. - - N (input) INTEGER - The number of columns of the matrix C. N >= 0. - - K (input) INTEGER - If VECT = 'Q', the number of columns in the original - matrix reduced by DGEBRD. - If VECT = 'P', the number of rows in the original - matrix reduced by DGEBRD. - K >= 0. - - A (input) DOUBLE PRECISION array, dimension - (LDA,min(nq,K)) if VECT = 'Q' - (LDA,nq) if VECT = 'P' - The vectors which define the elementary reflectors H(i) and - G(i), whose products determine the matrices Q and P, as - returned by DGEBRD. - - LDA (input) INTEGER - The leading dimension of the array A. - If VECT = 'Q', LDA >= max(1,nq); - if VECT = 'P', LDA >= max(1,min(nq,K)). - - TAU (input) DOUBLE PRECISION array, dimension (min(nq,K)) - TAU(i) must contain the scalar factor of the elementary - reflector H(i) or G(i) which determines Q or P, as returned - by DGEBRD in the array argument TAUQ or TAUP. - - C (input/output) DOUBLE PRECISION array, dimension (LDC,N) - On entry, the M-by-N matrix C. - On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q - or P*C or P**T*C or C*P or C*P**T. - - LDC (input) INTEGER - The leading dimension of the array C. LDC >= max(1,M). - - WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - - LWORK (input) INTEGER - The dimension of the array WORK. - If SIDE = 'L', LWORK >= max(1,N); - if SIDE = 'R', LWORK >= max(1,M). - For optimum performance LWORK >= N*NB if SIDE = 'L', and - LWORK >= M*NB if SIDE = 'R', where NB is the optimal - blocksize. - - If LWORK = -1, then a workspace query is assumed; the routine - only calculates the optimal size of the WORK array, returns - this value as the first entry of the WORK array, and no error - message related to LWORK is issued by XERBLA. - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - - ===================================================================== - - - Test the input arguments - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static integer c_n1 = -1; - static integer c__2 = 2; - - /* System generated locals */ - address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2]; - char ch__1[2]; - /* Builtin functions - Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - /* Local variables */ - static logical left; - extern logical lsame_(char *, char *); - static integer iinfo, i1, i2, nb, mi, ni, nq, nw; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *); - static logical notran; - extern /* Subroutine */ int dormqr_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *, integer *); - static logical applyq; - static char transt[1]; - static integer lwkopt; - static logical lquery; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - applyq = lsame_(vect, "Q"); - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q or P and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = *n; - } else { - nq = *n; - nw = *m; - } - if (! applyq && ! lsame_(vect, "P")) { - *info = -1; - } else if (! left && ! lsame_(side, "R")) { - *info = -2; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -3; - } else if (*m < 0) { - *info = -4; - } else if (*n < 0) { - *info = -5; - } else if (*k < 0) { - *info = -6; - } else /* if(complicated condition) */ { -/* Computing MAX */ - i__1 = 1, i__2 = min(nq,*k); - if (applyq && *lda < max(1,nq) || ! applyq && *lda < max(i__1,i__2)) { - *info = -8; - } else if (*ldc < max(1,*m)) { - *info = -11; - } else if (*lwork < max(1,nw) && ! lquery) { - *info = -13; - } - } - - if (*info == 0) { - if (applyq) { - if (left) { -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = *m - 1; - i__2 = *m - 1; - nb = ilaenv_(&c__1, "DORMQR", ch__1, &i__1, n, &i__2, &c_n1, ( - ftnlen)6, (ftnlen)2); - } else { -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = *n - 1; - i__2 = *n - 1; - nb = ilaenv_(&c__1, "DORMQR", ch__1, m, &i__1, &i__2, &c_n1, ( - ftnlen)6, (ftnlen)2); - } - } else { - if (left) { -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = *m - 1; - i__2 = *m - 1; - nb = ilaenv_(&c__1, "DORMLQ", ch__1, &i__1, n, &i__2, &c_n1, ( - ftnlen)6, (ftnlen)2); - } else { -/* Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = *n - 1; - i__2 = *n - 1; - nb = ilaenv_(&c__1, "DORMLQ", ch__1, m, &i__1, &i__2, &c_n1, ( - ftnlen)6, (ftnlen)2); - } - } - lwkopt = max(1,nw) * nb; - work[1] = (doublereal) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORMBR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - work[1] = 1.; - if (*m == 0 || *n == 0) { - return 0; - } - - if (applyq) { - -/* Apply Q */ - - if (nq >= *k) { - -/* Q was determined by a call to DGEBRD with nq >= k */ - - dormqr_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], lwork, &iinfo); - } else if (nq > 1) { - -/* Q was determined by a call to DGEBRD with nq < k */ - - if (left) { - mi = *m - 1; - ni = *n; - i1 = 2; - i2 = 1; - } else { - mi = *m; - ni = *n - 1; - i1 = 1; - i2 = 2; - } - i__1 = nq - 1; - dormqr_(side, trans, &mi, &ni, &i__1, &a_ref(2, 1), lda, &tau[1], - &c___ref(i1, i2), ldc, &work[1], lwork, &iinfo); - } - } else { - -/* Apply P */ - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - if (nq > *k) { - -/* P was determined by a call to DGEBRD with nq > k */ - - dormlq_(side, transt, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], lwork, &iinfo); - } else if (nq > 1) { - -/* P was determined by a call to DGEBRD with nq <= k */ - - if (left) { - mi = *m - 1; - ni = *n; - i1 = 2; - i2 = 1; - } else { - mi = *m; - ni = *n - 1; - i1 = 1; - i2 = 2; - } - i__1 = nq - 1; - dormlq_(side, transt, &mi, &ni, &i__1, &a_ref(1, 2), lda, &tau[1], - &c___ref(i1, i2), ldc, &work[1], lwork, &iinfo); - } - } - work[1] = (doublereal) lwkopt; - return 0; - -/* End of DORMBR */ - -} /* dormbr_ */ - -#undef c___ref -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dorml2.c b/ext/f2c_lapack/dorml2.c deleted file mode 100644 index c51018025..000000000 --- a/ext/f2c_lapack/dorml2.c +++ /dev/null @@ -1,217 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dorml2_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - February 29, 1992 - - - Purpose - ======= - - DORML2 overwrites the general real m by n matrix C with - - Q * C if SIDE = 'L' and TRANS = 'N', or - - Q'* C if SIDE = 'L' and TRANS = 'T', or - - C * Q if SIDE = 'R' and TRANS = 'N', or - - C * Q' if SIDE = 'R' and TRANS = 'T', - - where Q is a real orthogonal matrix defined as the product of k - elementary reflectors - - Q = H(k) . . . H(2) H(1) - - as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n - if SIDE = 'R'. - - Arguments - ========= - - SIDE (input) CHARACTER*1 - = 'L': apply Q or Q' from the Left - = 'R': apply Q or Q' from the Right - - TRANS (input) CHARACTER*1 - = 'N': apply Q (No transpose) - = 'T': apply Q' (Transpose) - - M (input) INTEGER - The number of rows of the matrix C. M >= 0. - - N (input) INTEGER - The number of columns of the matrix C. N >= 0. - - K (input) INTEGER - The number of elementary reflectors whose product defines - the matrix Q. - If SIDE = 'L', M >= K >= 0; - if SIDE = 'R', N >= K >= 0. - - A (input) DOUBLE PRECISION array, dimension - (LDA,M) if SIDE = 'L', - (LDA,N) if SIDE = 'R' - The i-th row must contain the vector which defines the - elementary reflector H(i), for i = 1,2,...,k, as returned by - DGELQF in the first k rows of its array argument A. - A is modified by the routine but restored on exit. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,K). - - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary - reflector H(i), as returned by DGELQF. - - C (input/output) DOUBLE PRECISION array, dimension (LDC,N) - On entry, the m by n matrix C. - On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. - - LDC (input) INTEGER - The leading dimension of the array C. LDC >= max(1,M). - - WORK (workspace) DOUBLE PRECISION array, dimension - (N) if SIDE = 'L', - (M) if SIDE = 'R' - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - - ===================================================================== - - - Test the input arguments - - Parameter adjustments */ - /* System generated locals */ - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2; - /* Local variables */ - static logical left; - static integer i__; - extern /* Subroutine */ int dlarf_(char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - doublereal *); - extern logical lsame_(char *, char *); - static integer i1, i2, i3, ic, jc, mi, ni, nq; - extern /* Subroutine */ int xerbla_(char *, integer *); - static logical notran; - static doublereal aii; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - -/* NQ is the order of Q */ - - if (left) { - nq = *m; - } else { - nq = *n; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < max(1,*k)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORML2", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - return 0; - } - - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = 1; - } else { - i1 = *k; - i2 = 1; - i3 = -1; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { - if (left) { - -/* H(i) is applied to C(i:m,1:n) */ - - mi = *m - i__ + 1; - ic = i__; - } else { - -/* H(i) is applied to C(1:m,i:n) */ - - ni = *n - i__ + 1; - jc = i__; - } - -/* Apply H(i) */ - - aii = a_ref(i__, i__); - a_ref(i__, i__) = 1.; - dlarf_(side, &mi, &ni, &a_ref(i__, i__), lda, &tau[i__], &c___ref(ic, - jc), ldc, &work[1]); - a_ref(i__, i__) = aii; -/* L10: */ - } - return 0; - -/* End of DORML2 */ - -} /* dorml2_ */ - -#undef c___ref -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dormlq.c b/ext/f2c_lapack/dormlq.c deleted file mode 100644 index 4f28f2888..000000000 --- a/ext/f2c_lapack/dormlq.c +++ /dev/null @@ -1,322 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dormlq_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *lwork, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1999 - - - Purpose - ======= - - DORMLQ overwrites the general real M-by-N matrix C with - - SIDE = 'L' SIDE = 'R' - TRANS = 'N': Q * C C * Q - TRANS = 'T': Q**T * C C * Q**T - - where Q is a real orthogonal matrix defined as the product of k - elementary reflectors - - Q = H(k) . . . H(2) H(1) - - as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N - if SIDE = 'R'. - - Arguments - ========= - - SIDE (input) CHARACTER*1 - = 'L': apply Q or Q**T from the Left; - = 'R': apply Q or Q**T from the Right. - - TRANS (input) CHARACTER*1 - = 'N': No transpose, apply Q; - = 'T': Transpose, apply Q**T. - - M (input) INTEGER - The number of rows of the matrix C. M >= 0. - - N (input) INTEGER - The number of columns of the matrix C. N >= 0. - - K (input) INTEGER - The number of elementary reflectors whose product defines - the matrix Q. - If SIDE = 'L', M >= K >= 0; - if SIDE = 'R', N >= K >= 0. - - A (input) DOUBLE PRECISION array, dimension - (LDA,M) if SIDE = 'L', - (LDA,N) if SIDE = 'R' - The i-th row must contain the vector which defines the - elementary reflector H(i), for i = 1,2,...,k, as returned by - DGELQF in the first k rows of its array argument A. - A is modified by the routine but restored on exit. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,K). - - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary - reflector H(i), as returned by DGELQF. - - C (input/output) DOUBLE PRECISION array, dimension (LDC,N) - On entry, the M-by-N matrix C. - On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. - - LDC (input) INTEGER - The leading dimension of the array C. LDC >= max(1,M). - - WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - - LWORK (input) INTEGER - The dimension of the array WORK. - If SIDE = 'L', LWORK >= max(1,N); - if SIDE = 'R', LWORK >= max(1,M). - For optimum performance LWORK >= N*NB if SIDE = 'L', and - LWORK >= M*NB if SIDE = 'R', where NB is the optimal - blocksize. - - If LWORK = -1, then a workspace query is assumed; the routine - only calculates the optimal size of the WORK array, returns - this value as the first entry of the WORK array, and no error - message related to LWORK is issued by XERBLA. - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - - ===================================================================== - - - Test the input arguments - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static integer c_n1 = -1; - static integer c__2 = 2; - static integer c__65 = 65; - - /* System generated locals */ - address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; - char ch__1[2]; - /* Builtin functions - Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - /* Local variables */ - static logical left; - static integer i__; - static doublereal t[4160] /* was [65][64] */; - extern logical lsame_(char *, char *); - static integer nbmin, iinfo, i1, i2, i3; - extern /* Subroutine */ int dorml2_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - static integer ib, ic, jc, nb, mi, ni; - extern /* Subroutine */ int dlarfb_(char *, char *, char *, char *, - integer *, integer *, integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *); - static integer nq, nw; - extern /* Subroutine */ int dlarft_(char *, char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - static logical notran; - static integer ldwork; - static char transt[1]; - static integer lwkopt; - static logical lquery; - static integer iws; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = *n; - } else { - nq = *n; - nw = *m; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < max(1,*k)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } else if (*lwork < max(1,nw) && ! lquery) { - *info = -12; - } - - if (*info == 0) { - -/* Determine the block size. NB may be at most NBMAX, where NBMAX - is used to define the local array T. - - Computing MIN - Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 64, i__2 = ilaenv_(&c__1, "DORMLQ", ch__1, m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)2); - nb = min(i__1,i__2); - lwkopt = max(1,nw) * nb; - work[1] = (doublereal) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORMLQ", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - work[1] = 1.; - return 0; - } - - nbmin = 2; - ldwork = nw; - if (nb > 1 && nb < *k) { - iws = nw * nb; - if (*lwork < iws) { - nb = *lwork / ldwork; -/* Computing MAX - Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 2, i__2 = ilaenv_(&c__2, "DORMLQ", ch__1, m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)2); - nbmin = max(i__1,i__2); - } - } else { - iws = nw; - } - - if (nb < nbmin || nb >= *k) { - -/* Use unblocked code */ - - dorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo); - } else { - -/* Use blocked code */ - - if (left && notran || ! left && ! notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - if (notran) { - *(unsigned char *)transt = 'T'; - } else { - *(unsigned char *)transt = 'N'; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = min(i__4,i__5); - -/* Form the triangular factor of the block reflector - H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__4 = nq - i__ + 1; - dlarft_("Forward", "Rowwise", &i__4, &ib, &a_ref(i__, i__), lda, & - tau[i__], t, &c__65); - if (left) { - -/* H or H' is applied to C(i:m,1:n) */ - - mi = *m - i__ + 1; - ic = i__; - } else { - -/* H or H' is applied to C(1:m,i:n) */ - - ni = *n - i__ + 1; - jc = i__; - } - -/* Apply H or H' */ - - dlarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a_ref( - i__, i__), lda, t, &c__65, &c___ref(ic, jc), ldc, &work[1] - , &ldwork); -/* L10: */ - } - } - work[1] = (doublereal) lwkopt; - return 0; - -/* End of DORMLQ */ - -} /* dormlq_ */ - -#undef c___ref -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dormqr.c b/ext/f2c_lapack/dormqr.c deleted file mode 100644 index f8237b9ef..000000000 --- a/ext/f2c_lapack/dormqr.c +++ /dev/null @@ -1,314 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dormqr_(char *side, char *trans, integer *m, integer *n, - integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal * - c__, integer *ldc, doublereal *work, integer *lwork, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1999 - - - Purpose - ======= - - DORMQR overwrites the general real M-by-N matrix C with - - SIDE = 'L' SIDE = 'R' - TRANS = 'N': Q * C C * Q - TRANS = 'T': Q**T * C C * Q**T - - where Q is a real orthogonal matrix defined as the product of k - elementary reflectors - - Q = H(1) H(2) . . . H(k) - - as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N - if SIDE = 'R'. - - Arguments - ========= - - SIDE (input) CHARACTER*1 - = 'L': apply Q or Q**T from the Left; - = 'R': apply Q or Q**T from the Right. - - TRANS (input) CHARACTER*1 - = 'N': No transpose, apply Q; - = 'T': Transpose, apply Q**T. - - M (input) INTEGER - The number of rows of the matrix C. M >= 0. - - N (input) INTEGER - The number of columns of the matrix C. N >= 0. - - K (input) INTEGER - The number of elementary reflectors whose product defines - the matrix Q. - If SIDE = 'L', M >= K >= 0; - if SIDE = 'R', N >= K >= 0. - - A (input) DOUBLE PRECISION array, dimension (LDA,K) - The i-th column must contain the vector which defines the - elementary reflector H(i), for i = 1,2,...,k, as returned by - DGEQRF in the first k columns of its array argument A. - A is modified by the routine but restored on exit. - - LDA (input) INTEGER - The leading dimension of the array A. - If SIDE = 'L', LDA >= max(1,M); - if SIDE = 'R', LDA >= max(1,N). - - TAU (input) DOUBLE PRECISION array, dimension (K) - TAU(i) must contain the scalar factor of the elementary - reflector H(i), as returned by DGEQRF. - - C (input/output) DOUBLE PRECISION array, dimension (LDC,N) - On entry, the M-by-N matrix C. - On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. - - LDC (input) INTEGER - The leading dimension of the array C. LDC >= max(1,M). - - WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) - On exit, if INFO = 0, WORK(1) returns the optimal LWORK. - - LWORK (input) INTEGER - The dimension of the array WORK. - If SIDE = 'L', LWORK >= max(1,N); - if SIDE = 'R', LWORK >= max(1,M). - For optimum performance LWORK >= N*NB if SIDE = 'L', and - LWORK >= M*NB if SIDE = 'R', where NB is the optimal - blocksize. - - If LWORK = -1, then a workspace query is assumed; the routine - only calculates the optimal size of the WORK array, returns - this value as the first entry of the WORK array, and no error - message related to LWORK is issued by XERBLA. - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - - ===================================================================== - - - Test the input arguments - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static integer c_n1 = -1; - static integer c__2 = 2; - static integer c__65 = 65; - - /* System generated locals */ - address a__1[2]; - integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, - i__5; - char ch__1[2]; - /* Builtin functions - Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - /* Local variables */ - static logical left; - static integer i__; - static doublereal t[4160] /* was [65][64] */; - extern logical lsame_(char *, char *); - static integer nbmin, iinfo, i1, i2, i3; - extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - static integer ib, ic, jc, nb, mi, ni; - extern /* Subroutine */ int dlarfb_(char *, char *, char *, char *, - integer *, integer *, integer *, doublereal *, integer *, - doublereal *, integer *, doublereal *, integer *, doublereal *, - integer *); - static integer nq, nw; - extern /* Subroutine */ int dlarft_(char *, char *, integer *, integer *, - doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - static logical notran; - static integer ldwork, lwkopt; - static logical lquery; - static integer iws; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] -#define c___ref(a_1,a_2) c__[(a_2)*c_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - --tau; - c_dim1 = *ldc; - c_offset = 1 + c_dim1 * 1; - c__ -= c_offset; - --work; - - /* Function Body */ - *info = 0; - left = lsame_(side, "L"); - notran = lsame_(trans, "N"); - lquery = *lwork == -1; - -/* NQ is the order of Q and NW is the minimum dimension of WORK */ - - if (left) { - nq = *m; - nw = *n; - } else { - nq = *n; - nw = *m; - } - if (! left && ! lsame_(side, "R")) { - *info = -1; - } else if (! notran && ! lsame_(trans, "T")) { - *info = -2; - } else if (*m < 0) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*k < 0 || *k > nq) { - *info = -5; - } else if (*lda < max(1,nq)) { - *info = -7; - } else if (*ldc < max(1,*m)) { - *info = -10; - } else if (*lwork < max(1,nw) && ! lquery) { - *info = -12; - } - - if (*info == 0) { - -/* Determine the block size. NB may be at most NBMAX, where NBMAX - is used to define the local array T. - - Computing MIN - Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQR", ch__1, m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)2); - nb = min(i__1,i__2); - lwkopt = max(1,nw) * nb; - work[1] = (doublereal) lwkopt; - } - - if (*info != 0) { - i__1 = -(*info); - xerbla_("DORMQR", &i__1); - return 0; - } else if (lquery) { - return 0; - } - -/* Quick return if possible */ - - if (*m == 0 || *n == 0 || *k == 0) { - work[1] = 1.; - return 0; - } - - nbmin = 2; - ldwork = nw; - if (nb > 1 && nb < *k) { - iws = nw * nb; - if (*lwork < iws) { - nb = *lwork / ldwork; -/* Computing MAX - Writing concatenation */ - i__3[0] = 1, a__1[0] = side; - i__3[1] = 1, a__1[1] = trans; - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); - i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQR", ch__1, m, n, k, &c_n1, ( - ftnlen)6, (ftnlen)2); - nbmin = max(i__1,i__2); - } - } else { - iws = nw; - } - - if (nb < nbmin || nb >= *k) { - -/* Use unblocked code */ - - dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[ - c_offset], ldc, &work[1], &iinfo); - } else { - -/* Use blocked code */ - - if (left && ! notran || ! left && notran) { - i1 = 1; - i2 = *k; - i3 = nb; - } else { - i1 = (*k - 1) / nb * nb + 1; - i2 = 1; - i3 = -nb; - } - - if (left) { - ni = *n; - jc = 1; - } else { - mi = *m; - ic = 1; - } - - i__1 = i2; - i__2 = i3; - for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { -/* Computing MIN */ - i__4 = nb, i__5 = *k - i__ + 1; - ib = min(i__4,i__5); - -/* Form the triangular factor of the block reflector - H = H(i) H(i+1) . . . H(i+ib-1) */ - - i__4 = nq - i__ + 1; - dlarft_("Forward", "Columnwise", &i__4, &ib, &a_ref(i__, i__), - lda, &tau[i__], t, &c__65); - if (left) { - -/* H or H' is applied to C(i:m,1:n) */ - - mi = *m - i__ + 1; - ic = i__; - } else { - -/* H or H' is applied to C(1:m,i:n) */ - - ni = *n - i__ + 1; - jc = i__; - } - -/* Apply H or H' */ - - dlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, & - a_ref(i__, i__), lda, t, &c__65, &c___ref(ic, jc), ldc, & - work[1], &ldwork); -/* L10: */ - } - } - work[1] = (doublereal) lwkopt; - return 0; - -/* End of DORMQR */ - -} /* dormqr_ */ - -#undef c___ref -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dpotf2.c b/ext/f2c_lapack/dpotf2.c deleted file mode 100644 index 4ceff060e..000000000 --- a/ext/f2c_lapack/dpotf2.c +++ /dev/null @@ -1,224 +0,0 @@ -/* dpotf2.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static doublereal c_b10 = -1.; -static doublereal c_b12 = 1.; - -/* Subroutine */ int dpotf2_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *info, ftnlen uplo_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - doublereal d__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - static integer j; - static doublereal ajj; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dgemv_(char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, integer *, ftnlen); - static logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - - -/* -- LAPACK routine (version 3.0) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ -/* Courant Institute, Argonne National Lab, and Rice University */ -/* February 29, 1992 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPOTF2 computes the Cholesky factorization of a real symmetric */ -/* positive definite matrix A. */ - -/* The factorization has the form */ -/* A = U' * U , if UPLO = 'U', or */ -/* A = L * L', if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is lower triangular. */ - -/* This is the unblocked version of the algorithm, calling Level 2 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* Specifies whether the upper or lower triangular part of the */ -/* symmetric matrix A is stored. */ -/* = 'U': Upper triangular */ -/* = 'L': Lower triangular */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* n by n upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading n by n lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* On exit, if INFO = 0, the factor U or L from the Cholesky */ -/* factorization A = U'*U or A = L*L'. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -k, the k-th argument had an illegal value */ -/* > 0: if INFO = k, the leading minor of order k is not */ -/* positive definite, and the factorization could not be */ -/* completed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1); - if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOTF2", &i__1, (ftnlen)6); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - - if (upper) { - -/* Compute the Cholesky factorization A = U'*U. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - -/* Compute U(J,J) and test for non-positive-definiteness. */ - - i__2 = j - 1; - ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j * a_dim1 + 1], &c__1, - &a[j * a_dim1 + 1], &c__1); - if (ajj <= 0.) { - a[j + j * a_dim1] = ajj; - goto L30; - } - ajj = sqrt(ajj); - a[j + j * a_dim1] = ajj; - -/* Compute elements J+1:N of row J. */ - - if (j < *n) { - i__2 = j - 1; - i__3 = *n - j; - dgemv_("Transpose", &i__2, &i__3, &c_b10, &a[(j + 1) * a_dim1 - + 1], lda, &a[j * a_dim1 + 1], &c__1, &c_b12, &a[j + ( - j + 1) * a_dim1], lda, (ftnlen)9); - i__2 = *n - j; - d__1 = 1. / ajj; - dscal_(&i__2, &d__1, &a[j + (j + 1) * a_dim1], lda); - } -/* L10: */ - } - } else { - -/* Compute the Cholesky factorization A = L*L'. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - -/* Compute L(J,J) and test for non-positive-definiteness. */ - - i__2 = j - 1; - ajj = a[j + j * a_dim1] - ddot_(&i__2, &a[j + a_dim1], lda, &a[j - + a_dim1], lda); - if (ajj <= 0.) { - a[j + j * a_dim1] = ajj; - goto L30; - } - ajj = sqrt(ajj); - a[j + j * a_dim1] = ajj; - -/* Compute elements J+1:N of column J. */ - - if (j < *n) { - i__2 = *n - j; - i__3 = j - 1; - dgemv_("No transpose", &i__2, &i__3, &c_b10, &a[j + 1 + - a_dim1], lda, &a[j + a_dim1], lda, &c_b12, &a[j + 1 + - j * a_dim1], &c__1, (ftnlen)12); - i__2 = *n - j; - d__1 = 1. / ajj; - dscal_(&i__2, &d__1, &a[j + 1 + j * a_dim1], &c__1); - } -/* L20: */ - } - } - goto L40; - -L30: - *info = j; - -L40: - return 0; - -/* End of DPOTF2 */ - -} /* dpotf2_ */ - diff --git a/ext/f2c_lapack/dpotrf.c b/ext/f2c_lapack/dpotrf.c deleted file mode 100644 index 4f55fb75b..000000000 --- a/ext/f2c_lapack/dpotrf.c +++ /dev/null @@ -1,254 +0,0 @@ -/* dpotrf.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c_n1 = -1; -static doublereal c_b13 = -1.; -static doublereal c_b14 = 1.; - -/* Subroutine */ int dpotrf_(char *uplo, integer *n, doublereal *a, integer * - lda, integer *info, ftnlen uplo_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - static integer j, jb, nb; - extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, - integer *, doublereal *, doublereal *, integer *, doublereal *, - integer *, doublereal *, doublereal *, integer *, ftnlen, ftnlen); - extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); - static logical upper; - extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *, - doublereal *, doublereal *, integer *, doublereal *, doublereal *, - integer *, ftnlen, ftnlen), dpotf2_(char *, integer *, - doublereal *, integer *, integer *, ftnlen), xerbla_(char *, - integer *, ftnlen); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - - -/* -- LAPACK routine (version 3.0) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ -/* Courant Institute, Argonne National Lab, and Rice University */ -/* March 31, 1993 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPOTRF computes the Cholesky factorization of a real symmetric */ -/* positive definite matrix A. */ - -/* The factorization has the form */ -/* A = U**T * U, if UPLO = 'U', or */ -/* A = L * L**T, if UPLO = 'L', */ -/* where U is an upper triangular matrix and L is lower triangular. */ - -/* This is the block version of the algorithm, calling Level 3 BLAS. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */ -/* On entry, the symmetric matrix A. If UPLO = 'U', the leading */ -/* N-by-N upper triangular part of A contains the upper */ -/* triangular part of the matrix A, and the strictly lower */ -/* triangular part of A is not referenced. If UPLO = 'L', the */ -/* leading N-by-N lower triangular part of A contains the lower */ -/* triangular part of the matrix A, and the strictly upper */ -/* triangular part of A is not referenced. */ - -/* On exit, if INFO = 0, the factor U or L from the Cholesky */ -/* factorization A = U**T*U or A = L*L**T. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the leading minor of order i is not */ -/* positive definite, and the factorization could not be */ -/* completed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1); - if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*lda < max(1,*n)) { - *info = -4; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOTRF", &i__1, (ftnlen)6); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Determine the block size for this environment. */ - - nb = ilaenv_(&c__1, "DPOTRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( - ftnlen)1); - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code. */ - - dpotf2_(uplo, n, &a[a_offset], lda, info, (ftnlen)1); - } else { - -/* Use blocked code. */ - - if (upper) { - -/* Compute the Cholesky factorization A = U'*U. */ - - i__1 = *n; - i__2 = nb; - for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { - -/* Update and factorize the current diagonal block and test */ -/* for non-positive-definiteness. */ - -/* Computing MIN */ - i__3 = nb, i__4 = *n - j + 1; - jb = min(i__3,i__4); - i__3 = j - 1; - dsyrk_("Upper", "Transpose", &jb, &i__3, &c_b13, &a[j * - a_dim1 + 1], lda, &c_b14, &a[j + j * a_dim1], lda, ( - ftnlen)5, (ftnlen)9); - dpotf2_("Upper", &jb, &a[j + j * a_dim1], lda, info, (ftnlen) - 5); - if (*info != 0) { - goto L30; - } - if (j + jb <= *n) { - -/* Compute the current block row. */ - - i__3 = *n - j - jb + 1; - i__4 = j - 1; - dgemm_("Transpose", "No transpose", &jb, &i__3, &i__4, & - c_b13, &a[j * a_dim1 + 1], lda, &a[(j + jb) * - a_dim1 + 1], lda, &c_b14, &a[j + (j + jb) * - a_dim1], lda, (ftnlen)9, (ftnlen)12); - i__3 = *n - j - jb + 1; - dtrsm_("Left", "Upper", "Transpose", "Non-unit", &jb, & - i__3, &c_b14, &a[j + j * a_dim1], lda, &a[j + (j - + jb) * a_dim1], lda, (ftnlen)4, (ftnlen)5, ( - ftnlen)9, (ftnlen)8); - } -/* L10: */ - } - - } else { - -/* Compute the Cholesky factorization A = L*L'. */ - - i__2 = *n; - i__1 = nb; - for (j = 1; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { - -/* Update and factorize the current diagonal block and test */ -/* for non-positive-definiteness. */ - -/* Computing MIN */ - i__3 = nb, i__4 = *n - j + 1; - jb = min(i__3,i__4); - i__3 = j - 1; - dsyrk_("Lower", "No transpose", &jb, &i__3, &c_b13, &a[j + - a_dim1], lda, &c_b14, &a[j + j * a_dim1], lda, ( - ftnlen)5, (ftnlen)12); - dpotf2_("Lower", &jb, &a[j + j * a_dim1], lda, info, (ftnlen) - 5); - if (*info != 0) { - goto L30; - } - if (j + jb <= *n) { - -/* Compute the current block column. */ - - i__3 = *n - j - jb + 1; - i__4 = j - 1; - dgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, & - c_b13, &a[j + jb + a_dim1], lda, &a[j + a_dim1], - lda, &c_b14, &a[j + jb + j * a_dim1], lda, ( - ftnlen)12, (ftnlen)9); - i__3 = *n - j - jb + 1; - dtrsm_("Right", "Lower", "Transpose", "Non-unit", &i__3, & - jb, &c_b14, &a[j + j * a_dim1], lda, &a[j + jb + - j * a_dim1], lda, (ftnlen)5, (ftnlen)5, (ftnlen)9, - (ftnlen)8); - } -/* L20: */ - } - } - } - goto L40; - -L30: - *info = *info + j - 1; - -L40: - return 0; - -/* End of DPOTRF */ - -} /* dpotrf_ */ - diff --git a/ext/f2c_lapack/dpotrs.c b/ext/f2c_lapack/dpotrs.c deleted file mode 100644 index e5d632002..000000000 --- a/ext/f2c_lapack/dpotrs.c +++ /dev/null @@ -1,171 +0,0 @@ -/* dpotrs.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static doublereal c_b9 = 1.; - -/* Subroutine */ int dpotrs_(char *uplo, integer *n, integer *nrhs, - doublereal *a, integer *lda, doublereal *b, integer *ldb, integer * - info, ftnlen uplo_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1; - - /* Local variables */ - extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); - static logical upper; - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - - -/* -- LAPACK routine (version 3.0) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ -/* Courant Institute, Argonne National Lab, and Rice University */ -/* March 31, 1993 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DPOTRS solves a system of linear equations A*X = B with a symmetric */ -/* positive definite matrix A using the Cholesky factorization */ -/* A = U**T*U or A = L*L**T computed by DPOTRF. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': Upper triangle of A is stored; */ -/* = 'L': Lower triangle of A is stored. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The triangular factor U or L from the Cholesky factorization */ -/* A = U**T*U or A = L*L**T, as computed by DPOTRF. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, the solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1); - if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) { - *info = -1; - } else if (*n < 0) { - *info = -2; - } else if (*nrhs < 0) { - *info = -3; - } else if (*lda < max(1,*n)) { - *info = -5; - } else if (*ldb < max(1,*n)) { - *info = -7; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DPOTRS", &i__1, (ftnlen)6); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0 || *nrhs == 0) { - return 0; - } - - if (upper) { - -/* Solve A*X = B where A = U'*U. */ - -/* Solve U'*X = B, overwriting B with X. */ - - dtrsm_("Left", "Upper", "Transpose", "Non-unit", n, nrhs, &c_b9, &a[ - a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( - ftnlen)9, (ftnlen)8); - -/* Solve U*X = B, overwriting B with X. */ - - dtrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b9, & - a[a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( - ftnlen)12, (ftnlen)8); - } else { - -/* Solve A*X = B where A = L*L'. */ - -/* Solve L*X = B, overwriting B with X. */ - - dtrsm_("Left", "Lower", "No transpose", "Non-unit", n, nrhs, &c_b9, & - a[a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( - ftnlen)12, (ftnlen)8); - -/* Solve L'*X = B, overwriting B with X. */ - - dtrsm_("Left", "Lower", "Transpose", "Non-unit", n, nrhs, &c_b9, &a[ - a_offset], lda, &b[b_offset], ldb, (ftnlen)4, (ftnlen)5, ( - ftnlen)9, (ftnlen)8); - } - - return 0; - -/* End of DPOTRS */ - -} /* dpotrs_ */ - diff --git a/ext/f2c_lapack/drscl.c b/ext/f2c_lapack/drscl.c deleted file mode 100644 index d8045c699..000000000 --- a/ext/f2c_lapack/drscl.c +++ /dev/null @@ -1,114 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int drscl_(integer *n, doublereal *sa, doublereal *sx, - integer *incx) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - September 30, 1994 - - - Purpose - ======= - - DRSCL multiplies an n-element real vector x by the real scalar 1/a. - This is done without overflow or underflow as long as - the final result x/a does not overflow or underflow. - - Arguments - ========= - - N (input) INTEGER - The number of components of the vector x. - - SA (input) DOUBLE PRECISION - The scalar a which is used to divide each component of x. - SA must be >= 0, or the subroutine will divide by zero. - - SX (input/output) DOUBLE PRECISION array, dimension - (1+(N-1)*abs(INCX)) - The n-element vector x. - - INCX (input) INTEGER - The increment between successive values of the vector SX. - > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n - - ===================================================================== - - - Quick return if possible - - Parameter adjustments */ - static doublereal cden; - static logical done; - static doublereal cnum, cden1, cnum1; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dlabad_(doublereal *, doublereal *); - extern doublereal dlamch_(char *); - static doublereal bignum, smlnum, mul; - - --sx; - - /* Function Body */ - if (*n <= 0) { - return 0; - } - -/* Get machine parameters */ - - smlnum = dlamch_("S"); - bignum = 1. / smlnum; - dlabad_(&smlnum, &bignum); - -/* Initialize the denominator to SA and the numerator to 1. */ - - cden = *sa; - cnum = 1.; - -L10: - cden1 = cden * smlnum; - cnum1 = cnum / bignum; - if (abs(cden1) > abs(cnum) && cnum != 0.) { - -/* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. */ - - mul = smlnum; - done = FALSE_; - cden = cden1; - } else if (abs(cnum1) > abs(cden)) { - -/* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. */ - - mul = bignum; - done = FALSE_; - cnum = cnum1; - } else { - -/* Multiply X by CNUM / CDEN and return. */ - - mul = cnum / cden; - done = TRUE_; - } - -/* Scale the vector X by MUL */ - - dscal_(n, &mul, &sx[1], incx); - - if (! done) { - goto L10; - } - - return 0; - -/* End of DRSCL */ - -} /* drscl_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dtrcon.c b/ext/f2c_lapack/dtrcon.c deleted file mode 100644 index 6323a364e..000000000 --- a/ext/f2c_lapack/dtrcon.c +++ /dev/null @@ -1,242 +0,0 @@ -/* dtrcon.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dtrcon_(char *norm, char *uplo, char *diag, integer *n, - doublereal *a, integer *lda, doublereal *rcond, doublereal *work, - integer *iwork, integer *info, ftnlen norm_len, ftnlen uplo_len, - ftnlen diag_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1; - doublereal d__1; - - /* Local variables */ - static integer ix, kase, kase1; - static doublereal scale; - extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *, - integer *); - static doublereal anorm; - static logical upper; - static doublereal xnorm; - extern doublereal dlamch_(char *, ftnlen); - extern /* Subroutine */ int dlacon_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - extern integer idamax_(integer *, doublereal *, integer *); - extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); - extern doublereal dlantr_(char *, char *, char *, integer *, integer *, - doublereal *, integer *, doublereal *, ftnlen, ftnlen, ftnlen); - static doublereal ainvnm; - extern /* Subroutine */ int dlatrs_(char *, char *, char *, char *, - integer *, doublereal *, integer *, doublereal *, doublereal *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen); - static logical onenrm; - static char normin[1]; - static doublereal smlnum; - static logical nounit; - - -/* -- LAPACK routine (version 3.0) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ -/* Courant Institute, Argonne National Lab, and Rice University */ -/* March 31, 1993 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRCON estimates the reciprocal of the condition number of a */ -/* triangular matrix A, in either the 1-norm or the infinity-norm. */ - -/* The norm of A is computed and an estimate is obtained for */ -/* norm(inv(A)), then the reciprocal of the condition number is */ -/* computed as */ -/* RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ - -/* Arguments */ -/* ========= */ - -/* NORM (input) CHARACTER*1 */ -/* Specifies whether the 1-norm condition number or the */ -/* infinity-norm condition number is required: */ -/* = '1' or 'O': 1-norm; */ -/* = 'I': Infinity-norm. */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */ -/* upper triangular part of the array A contains the upper */ -/* triangular matrix, and the strictly lower triangular part of */ -/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */ -/* triangular part of the array A contains the lower triangular */ -/* matrix, and the strictly upper triangular part of A is not */ -/* referenced. If DIAG = 'U', the diagonal elements of A are */ -/* also not referenced and are assumed to be 1. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* RCOND (output) DOUBLE PRECISION */ -/* The reciprocal of the condition number of the matrix A, */ -/* computed as RCOND = 1/(norm(A) * norm(inv(A))). */ - -/* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) */ - -/* IWORK (workspace) INTEGER array, dimension (N) */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --work; - --iwork; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1); - onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O", (ftnlen)1, ( - ftnlen)1); - nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1); - - if (! onenrm && ! lsame_(norm, "I", (ftnlen)1, (ftnlen)1)) { - *info = -1; - } else if (! upper && ! lsame_(uplo, "L", (ftnlen)1, (ftnlen)1)) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*lda < max(1,*n)) { - *info = -6; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRCON", &i__1, (ftnlen)6); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - *rcond = 1.; - return 0; - } - - *rcond = 0.; - smlnum = dlamch_("Safe minimum", (ftnlen)12) * (doublereal) max(1,*n); - -/* Compute the norm of the triangular matrix A. */ - - anorm = dlantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &work[1], ( - ftnlen)1, (ftnlen)1, (ftnlen)1); - -/* Continue only if ANORM > 0. */ - - if (anorm > 0.) { - -/* Estimate the norm of the inverse of A. */ - - ainvnm = 0.; - *(unsigned char *)normin = 'N'; - if (onenrm) { - kase1 = 1; - } else { - kase1 = 2; - } - kase = 0; -L10: - dlacon_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase); - if (kase != 0) { - if (kase == kase1) { - -/* Multiply by inv(A). */ - - dlatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset], - lda, &work[1], &scale, &work[(*n << 1) + 1], info, ( - ftnlen)1, (ftnlen)12, (ftnlen)1, (ftnlen)1); - } else { - -/* Multiply by inv(A'). */ - - dlatrs_(uplo, "Transpose", diag, normin, n, &a[a_offset], lda, - &work[1], &scale, &work[(*n << 1) + 1], info, ( - ftnlen)1, (ftnlen)9, (ftnlen)1, (ftnlen)1); - } - *(unsigned char *)normin = 'Y'; - -/* Multiply by 1/SCALE if doing so will not cause overflow. */ - - if (scale != 1.) { - ix = idamax_(n, &work[1], &c__1); - xnorm = (d__1 = work[ix], abs(d__1)); - if (scale < xnorm * smlnum || scale == 0.) { - goto L20; - } - drscl_(n, &scale, &work[1], &c__1); - } - goto L10; - } - -/* Compute the estimate of the reciprocal condition number. */ - - if (ainvnm != 0.) { - *rcond = 1. / anorm / ainvnm; - } - } - -L20: - return 0; - -/* End of DTRCON */ - -} /* dtrcon_ */ - diff --git a/ext/f2c_lapack/dtrti2.c b/ext/f2c_lapack/dtrti2.c deleted file mode 100644 index 6115d8a2d..000000000 --- a/ext/f2c_lapack/dtrti2.c +++ /dev/null @@ -1,166 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dtrti2_(char *uplo, char *diag, integer *n, doublereal * - a, integer *lda, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - February 29, 1992 - - - Purpose - ======= - - DTRTI2 computes the inverse of a real upper or lower triangular - matrix. - - This is the Level 2 BLAS version of the algorithm. - - Arguments - ========= - - UPLO (input) CHARACTER*1 - Specifies whether the matrix A is upper or lower triangular. - = 'U': Upper triangular - = 'L': Lower triangular - - DIAG (input) CHARACTER*1 - Specifies whether or not the matrix A is unit triangular. - = 'N': Non-unit triangular - = 'U': Unit triangular - - N (input) INTEGER - The order of the matrix A. N >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the triangular matrix A. If UPLO = 'U', the - leading n by n upper triangular part of the array A contains - the upper triangular matrix, and the strictly lower - triangular part of A is not referenced. If UPLO = 'L', the - leading n by n lower triangular part of the array A contains - the lower triangular matrix, and the strictly upper - triangular part of A is not referenced. If DIAG = 'U', the - diagonal elements of A are also not referenced and are - assumed to be 1. - - On exit, the (triangular) inverse of the original matrix, in - the same storage format. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,N). - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -k, the k-th argument had an illegal value - - ===================================================================== - - - Test the input parameters. - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - /* Local variables */ - static integer j; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *); - extern logical lsame_(char *, char *); - static logical upper; - extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *, - doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *); - static logical nounit; - static doublereal ajj; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - nounit = lsame_(diag, "N"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < max(1,*n)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRTI2", &i__1); - return 0; - } - - if (upper) { - -/* Compute inverse of upper triangular matrix. */ - - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - if (nounit) { - a_ref(j, j) = 1. / a_ref(j, j); - ajj = -a_ref(j, j); - } else { - ajj = -1.; - } - -/* Compute elements 1:j-1 of j-th column. */ - - i__2 = j - 1; - dtrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, & - a_ref(1, j), &c__1); - i__2 = j - 1; - dscal_(&i__2, &ajj, &a_ref(1, j), &c__1); -/* L10: */ - } - } else { - -/* Compute inverse of lower triangular matrix. */ - - for (j = *n; j >= 1; --j) { - if (nounit) { - a_ref(j, j) = 1. / a_ref(j, j); - ajj = -a_ref(j, j); - } else { - ajj = -1.; - } - if (j < *n) { - -/* Compute elements j+1:n of j-th column. */ - - i__1 = *n - j; - dtrmv_("Lower", "No transpose", diag, &i__1, &a_ref(j + 1, j - + 1), lda, &a_ref(j + 1, j), &c__1); - i__1 = *n - j; - dscal_(&i__1, &ajj, &a_ref(j + 1, j), &c__1); - } -/* L20: */ - } - } - - return 0; - -/* End of DTRTI2 */ - -} /* dtrti2_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dtrtri.c b/ext/f2c_lapack/dtrtri.c deleted file mode 100644 index 96deef904..000000000 --- a/ext/f2c_lapack/dtrtri.c +++ /dev/null @@ -1,225 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -/* Subroutine */ int dtrtri_(char *uplo, char *diag, integer *n, doublereal * - a, integer *lda, integer *info) -{ -/* -- LAPACK routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - March 31, 1993 - - - Purpose - ======= - - DTRTRI computes the inverse of a real upper or lower triangular - matrix A. - - This is the Level 3 BLAS version of the algorithm. - - Arguments - ========= - - UPLO (input) CHARACTER*1 - = 'U': A is upper triangular; - = 'L': A is lower triangular. - - DIAG (input) CHARACTER*1 - = 'N': A is non-unit triangular; - = 'U': A is unit triangular. - - N (input) INTEGER - The order of the matrix A. N >= 0. - - A (input/output) DOUBLE PRECISION array, dimension (LDA,N) - On entry, the triangular matrix A. If UPLO = 'U', the - leading N-by-N upper triangular part of the array A contains - the upper triangular matrix, and the strictly lower - triangular part of A is not referenced. If UPLO = 'L', the - leading N-by-N lower triangular part of the array A contains - the lower triangular matrix, and the strictly upper - triangular part of A is not referenced. If DIAG = 'U', the - diagonal elements of A are also not referenced and are - assumed to be 1. - On exit, the (triangular) inverse of the original matrix, in - the same storage format. - - LDA (input) INTEGER - The leading dimension of the array A. LDA >= max(1,N). - - INFO (output) INTEGER - = 0: successful exit - < 0: if INFO = -i, the i-th argument had an illegal value - > 0: if INFO = i, A(i,i) is exactly zero. The triangular - matrix is singular and its inverse can not be computed. - - ===================================================================== - - - Test the input parameters. - - Parameter adjustments */ - /* Table of constant values */ - static integer c__1 = 1; - static integer c_n1 = -1; - static integer c__2 = 2; - static doublereal c_b18 = 1.; - static doublereal c_b22 = -1.; - - /* System generated locals */ - address a__1[2]; - integer a_dim1, a_offset, i__1, i__2[2], i__3, i__4, i__5; - char ch__1[2]; - /* Builtin functions - Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - /* Local variables */ - static integer j; - extern logical lsame_(char *, char *); - extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *), dtrsm_( - char *, char *, char *, char *, integer *, integer *, doublereal * - , doublereal *, integer *, doublereal *, integer *); - static logical upper; - extern /* Subroutine */ int dtrti2_(char *, char *, integer *, doublereal - *, integer *, integer *); - static integer jb, nb, nn; - extern /* Subroutine */ int xerbla_(char *, integer *); - extern integer ilaenv_(integer *, char *, char *, integer *, integer *, - integer *, integer *, ftnlen, ftnlen); - static logical nounit; -#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1] - - - a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; - a -= a_offset; - - /* Function Body */ - *info = 0; - upper = lsame_(uplo, "U"); - nounit = lsame_(diag, "N"); - if (! upper && ! lsame_(uplo, "L")) { - *info = -1; - } else if (! nounit && ! lsame_(diag, "U")) { - *info = -2; - } else if (*n < 0) { - *info = -3; - } else if (*lda < max(1,*n)) { - *info = -5; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRTRI", &i__1); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Check for singularity if non-unit. */ - - if (nounit) { - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (a_ref(*info, *info) == 0.) { - return 0; - } -/* L10: */ - } - *info = 0; - } - -/* Determine the block size for this environment. - - Writing concatenation */ - i__2[0] = 1, a__1[0] = uplo; - i__2[1] = 1, a__1[1] = diag; - s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2); - nb = ilaenv_(&c__1, "DTRTRI", ch__1, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( - ftnlen)2); - if (nb <= 1 || nb >= *n) { - -/* Use unblocked code */ - - dtrti2_(uplo, diag, n, &a[a_offset], lda, info); - } else { - -/* Use blocked code */ - - if (upper) { - -/* Compute inverse of upper triangular matrix */ - - i__1 = *n; - i__3 = nb; - for (j = 1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) { -/* Computing MIN */ - i__4 = nb, i__5 = *n - j + 1; - jb = min(i__4,i__5); - -/* Compute rows 1:j-1 of current block column */ - - i__4 = j - 1; - dtrmm_("Left", "Upper", "No transpose", diag, &i__4, &jb, & - c_b18, &a[a_offset], lda, &a_ref(1, j), lda); - i__4 = j - 1; - dtrsm_("Right", "Upper", "No transpose", diag, &i__4, &jb, & - c_b22, &a_ref(j, j), lda, &a_ref(1, j), lda); - -/* Compute inverse of current diagonal block */ - - dtrti2_("Upper", diag, &jb, &a_ref(j, j), lda, info); -/* L20: */ - } - } else { - -/* Compute inverse of lower triangular matrix */ - - nn = (*n - 1) / nb * nb + 1; - i__3 = -nb; - for (j = nn; i__3 < 0 ? j >= 1 : j <= 1; j += i__3) { -/* Computing MIN */ - i__1 = nb, i__4 = *n - j + 1; - jb = min(i__1,i__4); - if (j + jb <= *n) { - -/* Compute rows j+jb:n of current block column */ - - i__1 = *n - j - jb + 1; - dtrmm_("Left", "Lower", "No transpose", diag, &i__1, &jb, - &c_b18, &a_ref(j + jb, j + jb), lda, &a_ref(j + - jb, j), lda); - i__1 = *n - j - jb + 1; - dtrsm_("Right", "Lower", "No transpose", diag, &i__1, &jb, - &c_b22, &a_ref(j, j), lda, &a_ref(j + jb, j), - lda); - } - -/* Compute inverse of current diagonal block */ - - dtrti2_("Lower", diag, &jb, &a_ref(j, j), lda, info); -/* L30: */ - } - } - } - - return 0; - -/* End of DTRTRI */ - -} /* dtrtri_ */ - -#undef a_ref - - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/dtrtrs.c b/ext/f2c_lapack/dtrtrs.c deleted file mode 100644 index 4c4035d8e..000000000 --- a/ext/f2c_lapack/dtrtrs.c +++ /dev/null @@ -1,187 +0,0 @@ -/* dtrtrs.f -- translated by f2c (version 20031025). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static doublereal c_b12 = 1.; - -/* Subroutine */ int dtrtrs_(char *uplo, char *trans, char *diag, integer *n, - integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer * - ldb, integer *info, ftnlen uplo_len, ftnlen trans_len, ftnlen - diag_len) -{ - /* System generated locals */ - integer a_dim1, a_offset, b_dim1, b_offset, i__1; - - /* Local variables */ - extern logical lsame_(char *, char *, ftnlen, ftnlen); - extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, - integer *, integer *, doublereal *, doublereal *, integer *, - doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen), xerbla_( - char *, integer *, ftnlen); - static logical nounit; - - -/* -- LAPACK routine (version 3.0) -- */ -/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */ -/* Courant Institute, Argonne National Lab, and Rice University */ -/* March 31, 1993 */ - -/* .. Scalar Arguments .. */ -/* .. */ -/* .. Array Arguments .. */ -/* .. */ - -/* Purpose */ -/* ======= */ - -/* DTRTRS solves a triangular system of the form */ - -/* A * X = B or A**T * X = B, */ - -/* where A is a triangular matrix of order N, and B is an N-by-NRHS */ -/* matrix. A check is made to verify that A is nonsingular. */ - -/* Arguments */ -/* ========= */ - -/* UPLO (input) CHARACTER*1 */ -/* = 'U': A is upper triangular; */ -/* = 'L': A is lower triangular. */ - -/* TRANS (input) CHARACTER*1 */ -/* Specifies the form of the system of equations: */ -/* = 'N': A * X = B (No transpose) */ -/* = 'T': A**T * X = B (Transpose) */ -/* = 'C': A**H * X = B (Conjugate transpose = Transpose) */ - -/* DIAG (input) CHARACTER*1 */ -/* = 'N': A is non-unit triangular; */ -/* = 'U': A is unit triangular. */ - -/* N (input) INTEGER */ -/* The order of the matrix A. N >= 0. */ - -/* NRHS (input) INTEGER */ -/* The number of right hand sides, i.e., the number of columns */ -/* of the matrix B. NRHS >= 0. */ - -/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */ -/* The triangular matrix A. If UPLO = 'U', the leading N-by-N */ -/* upper triangular part of the array A contains the upper */ -/* triangular matrix, and the strictly lower triangular part of */ -/* A is not referenced. If UPLO = 'L', the leading N-by-N lower */ -/* triangular part of the array A contains the lower triangular */ -/* matrix, and the strictly upper triangular part of A is not */ -/* referenced. If DIAG = 'U', the diagonal elements of A are */ -/* also not referenced and are assumed to be 1. */ - -/* LDA (input) INTEGER */ -/* The leading dimension of the array A. LDA >= max(1,N). */ - -/* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */ -/* On entry, the right hand side matrix B. */ -/* On exit, if INFO = 0, the solution matrix X. */ - -/* LDB (input) INTEGER */ -/* The leading dimension of the array B. LDB >= max(1,N). */ - -/* INFO (output) INTEGER */ -/* = 0: successful exit */ -/* < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > 0: if INFO = i, the i-th diagonal element of A is zero, */ -/* indicating that the matrix is singular and the solutions */ -/* X have not been computed. */ - -/* ===================================================================== */ - -/* .. Parameters .. */ -/* .. */ -/* .. Local Scalars .. */ -/* .. */ -/* .. External Functions .. */ -/* .. */ -/* .. External Subroutines .. */ -/* .. */ -/* .. Intrinsic Functions .. */ -/* .. */ -/* .. Executable Statements .. */ - -/* Test the input parameters. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - b_dim1 = *ldb; - b_offset = 1 + b_dim1; - b -= b_offset; - - /* Function Body */ - *info = 0; - nounit = lsame_(diag, "N", (ftnlen)1, (ftnlen)1); - if (! lsame_(uplo, "U", (ftnlen)1, (ftnlen)1) && ! lsame_(uplo, "L", ( - ftnlen)1, (ftnlen)1)) { - *info = -1; - } else if (! lsame_(trans, "N", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, - "T", (ftnlen)1, (ftnlen)1) && ! lsame_(trans, "C", (ftnlen)1, ( - ftnlen)1)) { - *info = -2; - } else if (! nounit && ! lsame_(diag, "U", (ftnlen)1, (ftnlen)1)) { - *info = -3; - } else if (*n < 0) { - *info = -4; - } else if (*nrhs < 0) { - *info = -5; - } else if (*lda < max(1,*n)) { - *info = -7; - } else if (*ldb < max(1,*n)) { - *info = -9; - } - if (*info != 0) { - i__1 = -(*info); - xerbla_("DTRTRS", &i__1, (ftnlen)6); - return 0; - } - -/* Quick return if possible */ - - if (*n == 0) { - return 0; - } - -/* Check for singularity. */ - - if (nounit) { - i__1 = *n; - for (*info = 1; *info <= i__1; ++(*info)) { - if (a[*info + *info * a_dim1] == 0.) { - return 0; - } -/* L10: */ - } - } - *info = 0; - -/* Solve A * x = b or A' * x = b. */ - - dtrsm_("Left", uplo, trans, diag, n, nrhs, &c_b12, &a[a_offset], lda, &b[ - b_offset], ldb, (ftnlen)4, (ftnlen)1, (ftnlen)1, (ftnlen)1); - - return 0; - -/* End of DTRTRS */ - -} /* dtrtrs_ */ - diff --git a/ext/f2c_lapack/ieeeck.c b/ext/f2c_lapack/ieeeck.c deleted file mode 100644 index 8834298da..000000000 --- a/ext/f2c_lapack/ieeeck.c +++ /dev/null @@ -1,156 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -integer ieeeck_(integer *ispec, real *zero, real *one) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1998 - - - Purpose - ======= - - IEEECK is called from the ILAENV to verify that Infinity and - possibly NaN arithmetic is safe (i.e. will not trap). - - Arguments - ========= - - ISPEC (input) INTEGER - Specifies whether to test just for inifinity arithmetic - or whether to test for infinity and NaN arithmetic. - = 0: Verify infinity arithmetic only. - = 1: Verify infinity and NaN arithmetic. - - ZERO (input) REAL - Must contain the value 0.0 - This is passed to prevent the compiler from optimizing - away this code. - - ONE (input) REAL - Must contain the value 1.0 - This is passed to prevent the compiler from optimizing - away this code. - - RETURN VALUE: INTEGER - = 0: Arithmetic failed to produce the correct answers - = 1: Arithmetic produced the correct answers */ - /* System generated locals */ - integer ret_val; - /* Local variables */ - static real neginf, posinf, negzro, newzro, nan1, nan2, nan3, nan4, nan5, - nan6; - - - ret_val = 1; - - posinf = *one / *zero; - if (posinf <= *one) { - ret_val = 0; - return ret_val; - } - - neginf = -(*one) / *zero; - if (neginf >= *zero) { - ret_val = 0; - return ret_val; - } - - negzro = *one / (neginf + *one); - if (negzro != *zero) { - ret_val = 0; - return ret_val; - } - - neginf = *one / negzro; - if (neginf >= *zero) { - ret_val = 0; - return ret_val; - } - - newzro = negzro + *zero; - if (newzro != *zero) { - ret_val = 0; - return ret_val; - } - - posinf = *one / newzro; - if (posinf <= *one) { - ret_val = 0; - return ret_val; - } - - neginf *= posinf; - if (neginf >= *zero) { - ret_val = 0; - return ret_val; - } - - posinf *= posinf; - if (posinf <= *one) { - ret_val = 0; - return ret_val; - } - - - - -/* Return if we were only asked to check infinity arithmetic */ - - if (*ispec == 0) { - return ret_val; - } - - nan1 = posinf + neginf; - - nan2 = posinf / neginf; - - nan3 = posinf / posinf; - - nan4 = posinf * *zero; - - nan5 = neginf * negzro; - - nan6 = nan5 * 0.f; - - if (nan1 == nan1) { - ret_val = 0; - return ret_val; - } - - if (nan2 == nan2) { - ret_val = 0; - return ret_val; - } - - if (nan3 == nan3) { - ret_val = 0; - return ret_val; - } - - if (nan4 == nan4) { - ret_val = 0; - return ret_val; - } - - if (nan5 == nan5) { - ret_val = 0; - return ret_val; - } - - if (nan6 == nan6) { - ret_val = 0; - return ret_val; - } - - return ret_val; -} /* ieeeck_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_lapack/ilaenv.c b/ext/f2c_lapack/ilaenv.c deleted file mode 100644 index eb24ea253..000000000 --- a/ext/f2c_lapack/ilaenv.c +++ /dev/null @@ -1,616 +0,0 @@ -#include "blaswrap.h" -#ifdef _cpluscplus -extern "C" { -#endif -#include "f2c.h" - -integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, - integer *n2, integer *n3, integer *n4, ftnlen name_len, ftnlen - opts_len) -{ -/* -- LAPACK auxiliary routine (version 3.0) -- - Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., - Courant Institute, Argonne National Lab, and Rice University - June 30, 1999 - - - Purpose - ======= - - ILAENV is called from the LAPACK routines to choose problem-dependent - parameters for the local environment. See ISPEC for a description of - the parameters. - - This version provides a set of parameters which should give good, - but not optimal, performance on many of the currently available - computers. Users are encouraged to modify this subroutine to set - the tuning parameters for their particular machine using the option - and problem size information in the arguments. - - This routine will not function correctly if it is converted to all - lower case. Converting it to all upper case is allowed. - - Arguments - ========= - - ISPEC (input) INTEGER - Specifies the parameter to be returned as the value of - ILAENV. - = 1: the optimal blocksize; if this value is 1, an unblocked - algorithm will give the best performance. - = 2: the minimum block size for which the block routine - should be used; if the usable block size is less than - this value, an unblocked routine should be used. - = 3: the crossover point (in a block routine, for N less - than this value, an unblocked routine should be used) - = 4: the number of shifts, used in the nonsymmetric - eigenvalue routines - = 5: the minimum column dimension for blocking to be used; - rectangular blocks must have dimension at least k by m, - where k is given by ILAENV(2,...) and m by ILAENV(5,...) - = 6: the crossover point for the SVD (when reducing an m by n - matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds - this value, a QR factorization is used first to reduce - the matrix to a triangular form.) - = 7: the number of processors - = 8: the crossover point for the multishift QR and QZ methods - for nonsymmetric eigenvalue problems. - = 9: maximum size of the subproblems at the bottom of the - computation tree in the divide-and-conquer algorithm - (used by xGELSD and xGESDD) - =10: ieee NaN arithmetic can be trusted not to trap - =11: infinity arithmetic can be trusted not to trap - - NAME (input) CHARACTER*(*) - The name of the calling subroutine, in either upper case or - lower case. - - OPTS (input) CHARACTER*(*) - The character options to the subroutine NAME, concatenated - into a single character string. For example, UPLO = 'U', - TRANS = 'T', and DIAG = 'N' for a triangular routine would - be specified as OPTS = 'UTN'. - - N1 (input) INTEGER - N2 (input) INTEGER - N3 (input) INTEGER - N4 (input) INTEGER - Problem dimensions for the subroutine NAME; these may not all - be required. - - (ILAENV) (output) INTEGER - >= 0: the value of the parameter specified by ISPEC - < 0: if ILAENV = -k, the k-th argument had an illegal value. - - Further Details - =============== - - The following conventions have been used when calling ILAENV from the - LAPACK routines: - 1) OPTS is a concatenation of all of the character options to - subroutine NAME, in the same order that they appear in the - argument list for NAME, even if they are not used in determining - the value of the parameter specified by ISPEC. - 2) The problem dimensions N1, N2, N3, N4 are specified in the order - that they appear in the argument list for NAME. N1 is used - first, N2 second, and so on, and unused problem dimensions are - passed a value of -1. - 3) The parameter value returned by ILAENV is checked for validity in - the calling subroutine. For example, ILAENV is used to retrieve - the optimal blocksize for STRTRI as follows: - - NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) - IF( NB.LE.1 ) NB = MAX( 1, N ) - - ===================================================================== */ - /* Table of constant values */ - static integer c__0 = 0; - static real c_b162 = 0.f; - static real c_b163 = 1.f; - static integer c__1 = 1; - - /* System generated locals */ - integer ret_val; - /* Builtin functions - Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); - integer s_cmp(char *, char *, ftnlen, ftnlen); - /* Local variables */ - static integer i__; - static logical cname, sname; - static integer nbmin; - static char c1[1], c2[2], c3[3], c4[2]; - static integer ic, nb; - extern integer ieeeck_(integer *, real *, real *); - static integer iz, nx; - static char subnam[6]; - - - - - switch (*ispec) { - case 1: goto L100; - case 2: goto L100; - case 3: goto L100; - case 4: goto L400; - case 5: goto L500; - case 6: goto L600; - case 7: goto L700; - case 8: goto L800; - case 9: goto L900; - case 10: goto L1000; - case 11: goto L1100; - } - -/* Invalid value for ISPEC */ - - ret_val = -1; - return ret_val; - -L100: - -/* Convert NAME to upper case if the first character is lower case. */ - - ret_val = 1; - s_copy(subnam, name__, (ftnlen)6, name_len); - ic = *(unsigned char *)subnam; - iz = 'Z'; - if (iz == 90 || iz == 122) { - -/* ASCII character set */ - - if (ic >= 97 && ic <= 122) { - *(unsigned char *)subnam = (char) (ic - 32); - for (i__ = 2; i__ <= 6; ++i__) { - ic = *(unsigned char *)&subnam[i__ - 1]; - if (ic >= 97 && ic <= 122) { - *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); - } -/* L10: */ - } - } - - } else if (iz == 233 || iz == 169) { - -/* EBCDIC character set */ - - if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && - ic <= 169) { - *(unsigned char *)subnam = (char) (ic + 64); - for (i__ = 2; i__ <= 6; ++i__) { - ic = *(unsigned char *)&subnam[i__ - 1]; - if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= - 162 && ic <= 169) { - *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64); - } -/* L20: */ - } - } - - } else if (iz == 218 || iz == 250) { - -/* Prime machines: ASCII+128 */ - - if (ic >= 225 && ic <= 250) { - *(unsigned char *)subnam = (char) (ic - 32); - for (i__ = 2; i__ <= 6; ++i__) { - ic = *(unsigned char *)&subnam[i__ - 1]; - if (ic >= 225 && ic <= 250) { - *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); - } -/* L30: */ - } - } - } - - *(unsigned char *)c1 = *(unsigned char *)subnam; - sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D'; - cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z'; - if (! (cname || sname)) { - return ret_val; - } - s_copy(c2, subnam + 1, (ftnlen)2, (ftnlen)2); - s_copy(c3, subnam + 3, (ftnlen)3, (ftnlen)3); - s_copy(c4, c3 + 1, (ftnlen)2, (ftnlen)2); - - switch (*ispec) { - case 1: goto L110; - case 2: goto L200; - case 3: goto L300; - } - -L110: - -/* ISPEC = 1: block size - - In these examples, separate code is provided for setting NB for - real and complex. We assume that NB will take the same value in - single or double precision. */ - - nb = 1; - - if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } else if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, - "RQF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen) - 3, (ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) - == 0) { - if (sname) { - nb = 32; - } else { - nb = 32; - } - } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 32; - } else { - nb = 32; - } - } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 32; - } else { - nb = 32; - } - } else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } - } else if (s_cmp(c2, "PO", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } - } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) { - nb = 32; - } else if (sname && s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) { - nb = 64; - } - } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { - nb = 64; - } else if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) { - nb = 32; - } else if (s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) { - nb = 64; - } - } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nb = 32; - } - } else if (*(unsigned char *)c3 == 'M') { - if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nb = 32; - } - } - } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nb = 32; - } - } else if (*(unsigned char *)c3 == 'M') { - if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nb = 32; - } - } - } else if (s_cmp(c2, "GB", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - if (*n4 <= 64) { - nb = 1; - } else { - nb = 32; - } - } else { - if (*n4 <= 64) { - nb = 1; - } else { - nb = 32; - } - } - } - } else if (s_cmp(c2, "PB", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - if (*n2 <= 64) { - nb = 1; - } else { - nb = 32; - } - } else { - if (*n2 <= 64) { - nb = 1; - } else { - nb = 32; - } - } - } - } else if (s_cmp(c2, "TR", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } - } else if (s_cmp(c2, "LA", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, "UUM", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nb = 64; - } else { - nb = 64; - } - } - } else if (sname && s_cmp(c2, "ST", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, "EBZ", (ftnlen)3, (ftnlen)3) == 0) { - nb = 1; - } - } - ret_val = nb; - return ret_val; - -L200: - -/* ISPEC = 2: minimum block size */ - - nbmin = 2; - if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", ( - ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, ( - ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0) - { - if (sname) { - nbmin = 2; - } else { - nbmin = 2; - } - } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nbmin = 2; - } else { - nbmin = 2; - } - } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nbmin = 2; - } else { - nbmin = 2; - } - } else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nbmin = 2; - } else { - nbmin = 2; - } - } - } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nbmin = 8; - } else { - nbmin = 8; - } - } else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) { - nbmin = 2; - } - } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) { - nbmin = 2; - } - } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nbmin = 2; - } - } else if (*(unsigned char *)c3 == 'M') { - if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nbmin = 2; - } - } - } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nbmin = 2; - } - } else if (*(unsigned char *)c3 == 'M') { - if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nbmin = 2; - } - } - } - ret_val = nbmin; - return ret_val; - -L300: - -/* ISPEC = 3: crossover point */ - - nx = 0; - if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", ( - ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, ( - ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0) - { - if (sname) { - nx = 128; - } else { - nx = 128; - } - } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nx = 128; - } else { - nx = 128; - } - } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) { - if (sname) { - nx = 128; - } else { - nx = 128; - } - } - } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) { - if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) { - nx = 32; - } - } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) { - if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) { - nx = 32; - } - } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nx = 128; - } - } - } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) { - if (*(unsigned char *)c3 == 'G') { - if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", - (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( - ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == - 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( - c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( - ftnlen)2, (ftnlen)2) == 0) { - nx = 128; - } - } - } - ret_val = nx; - return ret_val; - -L400: - -/* ISPEC = 4: number of shifts (used by xHSEQR) */ - - ret_val = 6; - return ret_val; - -L500: - -/* ISPEC = 5: minimum column dimension (not used) */ - - ret_val = 2; - return ret_val; - -L600: - -/* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) */ - - ret_val = (integer) ((real) min(*n1,*n2) * 1.6f); - return ret_val; - -L700: - -/* ISPEC = 7: number of processors (not used) */ - - ret_val = 1; - return ret_val; - -L800: - -/* ISPEC = 8: crossover point for multishift (used by xHSEQR) */ - - ret_val = 50; - return ret_val; - -L900: - -/* ISPEC = 9: maximum size of the subproblems at the bottom of the - computation tree in the divide-and-conquer algorithm - (used by xGELSD and xGESDD) */ - - ret_val = 25; - return ret_val; - -L1000: - -/* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap - - ILAENV = 0 */ - ret_val = 1; - if (ret_val == 1) { - ret_val = ieeeck_(&c__0, &c_b162, &c_b163); - } - return ret_val; - -L1100: - -/* ISPEC = 11: infinity arithmetic can be trusted not to trap - - ILAENV = 0 */ - ret_val = 1; - if (ret_val == 1) { - ret_val = ieeeck_(&c__1, &c_b162, &c_b163); - } - return ret_val; - -/* End of ILAENV */ - -} /* ilaenv_ */ - -#ifdef _cpluscplus -} -#endif diff --git a/ext/f2c_libs/.gitignore b/ext/f2c_libs/.gitignore deleted file mode 100644 index 4ed511628..000000000 --- a/ext/f2c_libs/.gitignore +++ /dev/null @@ -1 +0,0 @@ -arith.h diff --git a/ext/f2c_libs/abort_.c b/ext/f2c_libs/abort_.c deleted file mode 100644 index fa5aae6b7..000000000 --- a/ext/f2c_libs/abort_.c +++ /dev/null @@ -1,22 +0,0 @@ -#include "stdio.h" -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -extern VOID sig_die(); - -int abort_() -#else -extern void sig_die(char*,int); - -int abort_(void) -#endif -{ -sig_die("Fortran abort routine called", 1); -return 0; /* not reached */ -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/arithchk/arithchk.c b/ext/f2c_libs/arithchk/arithchk.c deleted file mode 100644 index 94c93e2f2..000000000 --- a/ext/f2c_libs/arithchk/arithchk.c +++ /dev/null @@ -1,225 +0,0 @@ -/**************************************************************** -Copyright (C) 1997, 1998, 2000 Lucent Technologies -All Rights Reserved - -Permission to use, copy, modify, and distribute this software and -its documentation for any purpose and without fee is hereby -granted, provided that the above copyright notice appear in all -copies and that both that the copyright notice and this -permission notice and warranty disclaimer appear in supporting -documentation, and that the name of Lucent or any of its entities -not be used in advertising or publicity pertaining to -distribution of the software without specific, written prior -permission. - -LUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, -INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. -IN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY -SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER -IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, -ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF -THIS SOFTWARE. -****************************************************************/ - -/* Try to deduce arith.h from arithmetic properties. */ - -#include -#include -#include - -#ifdef NO_FPINIT -#define fpinit_ASL() -#else -#ifndef KR_headers -extern -#ifdef __cplusplus - "C" -#endif - void fpinit_ASL(void); -#endif /*KR_headers*/ -#endif /*NO_FPINIT*/ - - static int dalign; - typedef struct -Akind { - char *name; - int kind; - } Akind; - - static Akind -IEEE_8087 = { "IEEE_8087", 1 }, -IEEE_MC68k = { "IEEE_MC68k", 2 }, -IBM = { "IBM", 3 }, -VAX = { "VAX", 4 }, -CRAY = { "CRAY", 5}; - - static double t_nan; - - static Akind * -Lcheck() -{ - union { - double d; - long L[2]; - } u; - struct { - double d; - long L; - } x[2]; - - if (sizeof(x) > 2*(sizeof(double) + sizeof(long))) - dalign = 1; - u.L[0] = u.L[1] = 0; - u.d = 1e13; - if (u.L[0] == 1117925532 && u.L[1] == -448790528) - return &IEEE_MC68k; - if (u.L[1] == 1117925532 && u.L[0] == -448790528) - return &IEEE_8087; - if (u.L[0] == -2065213935 && u.L[1] == 10752) - return &VAX; - if (u.L[0] == 1267827943 && u.L[1] == 704643072) - return &IBM; - return 0; - } - - static Akind * -icheck() -{ - union { - double d; - int L[2]; - } u; - struct { - double d; - int L; - } x[2]; - - if (sizeof(x) > 2*(sizeof(double) + sizeof(int))) - dalign = 1; - u.L[0] = u.L[1] = 0; - u.d = 1e13; - if (u.L[0] == 1117925532 && u.L[1] == -448790528) - return &IEEE_MC68k; - if (u.L[1] == 1117925532 && u.L[0] == -448790528) - return &IEEE_8087; - if (u.L[0] == -2065213935 && u.L[1] == 10752) - return &VAX; - if (u.L[0] == 1267827943 && u.L[1] == 704643072) - return &IBM; - return 0; - } - -char *emptyfmt = ""; /* avoid possible warning message with printf("") */ - - static Akind * -ccheck() -{ - union { - double d; - long L; - } u; - long Cray1; - - /* Cray1 = 4617762693716115456 -- without overflow on non-Crays */ - Cray1 = printf(emptyfmt) < 0 ? 0 : 4617762; - if (printf(emptyfmt, Cray1) >= 0) - Cray1 = 1000000*Cray1 + 693716; - if (printf(emptyfmt, Cray1) >= 0) - Cray1 = 1000000*Cray1 + 115456; - u.d = 1e13; - if (u.L == Cray1) - return &CRAY; - return 0; - } - - static int -fzcheck() -{ - double a, b; - int i; - - a = 1.; - b = .1; - for(i = 155;; b *= b, i >>= 1) { - if (i & 1) { - a *= b; - if (i == 1) - break; - } - } - b = a * a; - return b == 0.; - } - - static int -need_nancheck() -{ - double t; - - errno = 0; - t = log(t_nan); - if (errno == 0) - return 1; - errno = 0; - t = sqrt(t_nan); - return errno == 0; - } - -main() -{ - FILE *f; - Akind *a = 0; - int Ldef = 0; - - fpinit_ASL(); -#ifdef WRITE_ARITH_H /* for Symantec's buggy "make" */ - f = fopen("arith.h", "w"); - if (!f) { - printf("Cannot open arith.h\n"); - return 1; - } -#else - f = stdout; -#endif - - if (sizeof(double) == 2*sizeof(long)) - a = Lcheck(); - else if (sizeof(double) == 2*sizeof(int)) { - Ldef = 1; - a = icheck(); - } - else if (sizeof(double) == sizeof(long)) - a = ccheck(); - if (a) { - fprintf(f, "#define %s\n#define Arith_Kind_ASL %d\n", - a->name, a->kind); - if (Ldef) - fprintf(f, "#define Long int\n#define Intcast (int)(long)\n"); - if (dalign) - fprintf(f, "#define Double_Align\n"); - if (sizeof(char*) == 8) - fprintf(f, "#define X64_bit_pointers\n"); -#ifndef NO_LONG_LONG - if (sizeof(long long) < 8) -#endif - fprintf(f, "#define NO_LONG_LONG\n"); - if (a->kind <= 2) { - if (fzcheck()) - fprintf(f, "#define Sudden_Underflow\n"); - t_nan = -a->kind; - if (need_nancheck()) - fprintf(f, "#define NANCHECK\n"); - } - return 0; - } - fprintf(f, "/* Unknown arithmetic */\n"); - return 1; - } - -#ifdef __sun -#ifdef __i386 -/* kludge for Intel Solaris */ -void fpsetprec(int x) { } -#endif -#endif diff --git a/ext/f2c_libs/backspac.c b/ext/f2c_libs/backspac.c deleted file mode 100644 index 908a61897..000000000 --- a/ext/f2c_libs/backspac.c +++ /dev/null @@ -1,76 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#ifdef __cplusplus -extern "C" { -#endif -#ifdef KR_headers -integer f_back(a) alist *a; -#else -integer f_back(alist *a) -#endif -{ unit *b; - OFF_T v, w, x, y, z; - uiolen n; - FILE *f; - - f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */ - if(a->aunit >= MXUNIT || a->aunit < 0) - err(a->aerr,101,"backspace") - if(b->useek==0) err(a->aerr,106,"backspace") - if(b->ufd == NULL) { - fk_open(1, 1, a->aunit); - return(0); - } - if(b->uend==1) - { b->uend=0; - return(0); - } - if(b->uwrt) { - t_runc(a); - if (f__nowreading(b)) - err(a->aerr,errno,"backspace") - } - f = b->ufd; /* may have changed in t_runc() */ - if(b->url>0) - { - x=FTELL(f); - y = x % b->url; - if(y == 0) x--; - x /= b->url; - x *= b->url; - (void) FSEEK(f,x,SEEK_SET); - return(0); - } - - if(b->ufmt==0) - { FSEEK(f,-(OFF_T)sizeof(uiolen),SEEK_CUR); - fread((char *)&n,sizeof(uiolen),1,f); - FSEEK(f,-(OFF_T)n-2*sizeof(uiolen),SEEK_CUR); - return(0); - } - w = x = FTELL(f); - z = 0; - loop: - while(x) { - x -= x < 64 ? x : 64; - FSEEK(f,x,SEEK_SET); - for(y = x; y < w; y++) { - if (getc(f) != '\n') - continue; - v = FTELL(f); - if (v == w) { - if (z) - goto break2; - goto loop; - } - z = v; - } - err(a->aerr,(EOF),"backspace") - } - break2: - FSEEK(f, z, SEEK_SET); - return 0; -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/c_abs.c b/ext/f2c_libs/c_abs.c deleted file mode 100644 index 858f2c8b4..000000000 --- a/ext/f2c_libs/c_abs.c +++ /dev/null @@ -1,20 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -extern double f__cabs(); - -double c_abs(z) complex *z; -#else -extern double f__cabs(double, double); - -double c_abs(complex *z) -#endif -{ -return( f__cabs( z->r, z->i ) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/c_cos.c b/ext/f2c_libs/c_cos.c deleted file mode 100644 index ceb873d5d..000000000 --- a/ext/f2c_libs/c_cos.c +++ /dev/null @@ -1,23 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -extern double sin(), cos(), sinh(), cosh(); - -VOID c_cos(r, z) complex *r, *z; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif - -void c_cos(complex *r, complex *z) -#endif -{ - double zi = z->i, zr = z->r; - r->r = (real) (cos(zr) * cosh(zi)); - r->i = (real) (- sin(zr) * sinh(zi)); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/c_div.c b/ext/f2c_libs/c_div.c deleted file mode 100644 index db8aa38c1..000000000 --- a/ext/f2c_libs/c_div.c +++ /dev/null @@ -1,53 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -extern VOID sig_die(); -VOID c_div(c, a, b) -complex *a, *b, *c; -#else -extern void sig_die(char*,int); -void c_div(complex *c, complex *a, complex *b) -#endif -{ - double ratio, den; - double abr, abi, cr; - - if( (abr = b->r) < 0.) - abr = - abr; - if( (abi = b->i) < 0.) - abi = - abi; - if( abr <= abi ) - { - if(abi == 0) { -#ifdef IEEE_COMPLEX_DIVIDE - float af, bf; - af = bf = abr; - if (a->i != 0 || a->r != 0) - af = 1.; - c->i = c->r = af / bf; - return; -#else - sig_die("complex division by zero", 1); -#endif - } - ratio = (double)b->r / b->i ; - den = b->i * (1 + ratio*ratio); - cr = (a->r*ratio + a->i) / den; - c->i = (real) ((a->i*ratio - a->r) / den); - } - - else - { - ratio = (double)b->i / b->r ; - den = b->r * (1 + ratio*ratio); - cr = (a->r + a->i*ratio) / den; - c->i = (real) ((a->i - a->r*ratio) / den); - } - c->r = (real) cr; - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/c_exp.c b/ext/f2c_libs/c_exp.c deleted file mode 100644 index bfc1b1a30..000000000 --- a/ext/f2c_libs/c_exp.c +++ /dev/null @@ -1,25 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -extern double exp(), cos(), sin(); - - VOID c_exp(r, z) complex *r, *z; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif - -void c_exp(complex *r, complex *z) -#endif -{ - double expx, zi = z->i; - - expx = exp(z->r); - r->r = (real) (expx * cos(zi)); - r->i = (real) (expx * sin(zi)); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/c_log.c b/ext/f2c_libs/c_log.c deleted file mode 100644 index c8eec926e..000000000 --- a/ext/f2c_libs/c_log.c +++ /dev/null @@ -1,23 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -extern double log(), f__cabs(), atan2(); -VOID c_log(r, z) complex *r, *z; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -extern double f__cabs(double, double); - -void c_log(complex *r, complex *z) -#endif -{ - double zi, zr; - r->i = (real) atan2(zi = z->i, zr = z->r); - r->r = (real) log( f__cabs(zr, zi) ); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/c_sin.c b/ext/f2c_libs/c_sin.c deleted file mode 100644 index b55fcb5dd..000000000 --- a/ext/f2c_libs/c_sin.c +++ /dev/null @@ -1,23 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -extern double sin(), cos(), sinh(), cosh(); - -VOID c_sin(r, z) complex *r, *z; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif - -void c_sin(complex *r, complex *z) -#endif -{ - double zi = z->i, zr = z->r; - r->r = (real) (sin(zr) * cosh(zi)); - r->i = (real) (cos(zr) * sinh(zi)); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/c_sqrt.c b/ext/f2c_libs/c_sqrt.c deleted file mode 100644 index 714743580..000000000 --- a/ext/f2c_libs/c_sqrt.c +++ /dev/null @@ -1,42 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -extern double sqrt(), f__cabs(); - -VOID c_sqrt(r, z) complex *r, *z; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -extern double f__cabs(double, double); - -void c_sqrt(complex *r, complex *z) -#endif -{ - double mag, t; - double zi = z->i, zr = z->r; - - if( (mag = f__cabs(zr, zi)) == 0.) - r->r = r->i = 0.; - else if(zr > 0) - { - t = sqrt(0.5 * (mag + zr) ); - r->r = (real) t; - t = zi / t; - r->i = (real) (0.5 * t); - } - else - { - t = sqrt(0.5 * (mag - zr) ); - if(zi < 0) - t = -t; - r->i = (real) t; - t = zi / t; - r->r = (real) (0.5 * t); - } - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/cabs.c b/ext/f2c_libs/cabs.c deleted file mode 100644 index 84750d505..000000000 --- a/ext/f2c_libs/cabs.c +++ /dev/null @@ -1,33 +0,0 @@ -#ifdef KR_headers -extern double sqrt(); -double f__cabs(real, imag) double real, imag; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double f__cabs(double real, double imag) -#endif -{ -double temp; - -if(real < 0) - real = -real; -if(imag < 0) - imag = -imag; -if(imag > real){ - temp = real; - real = imag; - imag = temp; -} -if((real+imag) == real) - return(real); - -temp = imag/real; -temp = real*sqrt(1.0 + temp*temp); /*overflow!!*/ -return(temp); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/close.c b/ext/f2c_libs/close.c deleted file mode 100644 index e958c7172..000000000 --- a/ext/f2c_libs/close.c +++ /dev/null @@ -1,101 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#ifdef KR_headers -integer f_clos(a) cllist *a; -#else -#undef abs -#undef min -#undef max -#include "stdlib.h" -#ifdef NON_UNIX_STDIO -#ifndef unlink -#define unlink remove -#endif -#else -#ifdef MSDOS -#include "io.h" -#else -#ifdef __cplusplus -extern "C" int unlink(const char*); -#else -extern int unlink(const char*); -#endif -#endif -#endif - -#ifdef __cplusplus -extern "C" { -#endif - -integer f_clos(cllist *a) -#endif -{ unit *b; - - if(a->cunit >= MXUNIT) return(0); - b= &f__units[a->cunit]; - if(b->ufd==NULL) - goto done; - if (b->uscrtch == 1) - goto Delete; - if (!a->csta) - goto Keep; - switch(*a->csta) { - default: - Keep: - case 'k': - case 'K': - if(b->uwrt == 1) - t_runc((alist *)a); - if(b->ufnm) { - fclose(b->ufd); - free(b->ufnm); - } - break; - case 'd': - case 'D': - Delete: - fclose(b->ufd); - if(b->ufnm) { - unlink(b->ufnm); /*SYSDEP*/ - free(b->ufnm); - } - } - b->ufd=NULL; - done: - b->uend=0; - b->ufnm=NULL; - return(0); - } - void -#ifdef KR_headers -f_exit() -#else -f_exit(void) -#endif -{ int i; - static cllist xx; - if (!xx.cerr) { - xx.cerr=1; - xx.csta=NULL; - for(i=0;i= 0) - return(*x); -return(- *x); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_acos.c b/ext/f2c_libs/d_acos.c deleted file mode 100644 index 69005b56d..000000000 --- a/ext/f2c_libs/d_acos.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double acos(); -double d_acos(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double d_acos(doublereal *x) -#endif -{ -return( acos(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_asin.c b/ext/f2c_libs/d_asin.c deleted file mode 100644 index d5196ab10..000000000 --- a/ext/f2c_libs/d_asin.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double asin(); -double d_asin(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double d_asin(doublereal *x) -#endif -{ -return( asin(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_atan.c b/ext/f2c_libs/d_atan.c deleted file mode 100644 index d8856f8d6..000000000 --- a/ext/f2c_libs/d_atan.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double atan(); -double d_atan(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double d_atan(doublereal *x) -#endif -{ -return( atan(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_atn2.c b/ext/f2c_libs/d_atn2.c deleted file mode 100644 index 56113850a..000000000 --- a/ext/f2c_libs/d_atn2.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double atan2(); -double d_atn2(x,y) doublereal *x, *y; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double d_atn2(doublereal *x, doublereal *y) -#endif -{ -return( atan2(*x,*y) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_cnjg.c b/ext/f2c_libs/d_cnjg.c deleted file mode 100644 index 38471d9bc..000000000 --- a/ext/f2c_libs/d_cnjg.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - - VOID -#ifdef KR_headers -d_cnjg(r, z) doublecomplex *r, *z; -#else -d_cnjg(doublecomplex *r, doublecomplex *z) -#endif -{ - doublereal zi = z->i; - r->r = z->r; - r->i = -zi; - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_cos.c b/ext/f2c_libs/d_cos.c deleted file mode 100644 index 12def9ad0..000000000 --- a/ext/f2c_libs/d_cos.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double cos(); -double d_cos(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double d_cos(doublereal *x) -#endif -{ -return( cos(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_cosh.c b/ext/f2c_libs/d_cosh.c deleted file mode 100644 index 9214c7a0d..000000000 --- a/ext/f2c_libs/d_cosh.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double cosh(); -double d_cosh(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double d_cosh(doublereal *x) -#endif -{ -return( cosh(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_dim.c b/ext/f2c_libs/d_dim.c deleted file mode 100644 index 627ddb690..000000000 --- a/ext/f2c_libs/d_dim.c +++ /dev/null @@ -1,16 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -double d_dim(a,b) doublereal *a, *b; -#else -double d_dim(doublereal *a, doublereal *b) -#endif -{ -return( *a > *b ? *a - *b : 0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_exp.c b/ext/f2c_libs/d_exp.c deleted file mode 100644 index e9ab5d442..000000000 --- a/ext/f2c_libs/d_exp.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double exp(); -double d_exp(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double d_exp(doublereal *x) -#endif -{ -return( exp(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_imag.c b/ext/f2c_libs/d_imag.c deleted file mode 100644 index d17b9dd59..000000000 --- a/ext/f2c_libs/d_imag.c +++ /dev/null @@ -1,16 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -double d_imag(z) doublecomplex *z; -#else -double d_imag(doublecomplex *z) -#endif -{ -return(z->i); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_int.c b/ext/f2c_libs/d_int.c deleted file mode 100644 index 6da4ce35e..000000000 --- a/ext/f2c_libs/d_int.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double floor(); -double d_int(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double d_int(doublereal *x) -#endif -{ -return( (*x>0) ? floor(*x) : -floor(- *x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_lg10.c b/ext/f2c_libs/d_lg10.c deleted file mode 100644 index 664c19d9e..000000000 --- a/ext/f2c_libs/d_lg10.c +++ /dev/null @@ -1,21 +0,0 @@ -#include "f2c.h" - -#define log10e 0.43429448190325182765 - -#ifdef KR_headers -double log(); -double d_lg10(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double d_lg10(doublereal *x) -#endif -{ -return( log10e * log(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_log.c b/ext/f2c_libs/d_log.c deleted file mode 100644 index e74be02c5..000000000 --- a/ext/f2c_libs/d_log.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double log(); -double d_log(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double d_log(doublereal *x) -#endif -{ -return( log(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_mod.c b/ext/f2c_libs/d_mod.c deleted file mode 100644 index 3766d9fa8..000000000 --- a/ext/f2c_libs/d_mod.c +++ /dev/null @@ -1,46 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -#ifdef IEEE_drem -double drem(); -#else -double floor(); -#endif -double d_mod(x,y) doublereal *x, *y; -#else -#ifdef IEEE_drem -double drem(double, double); -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -#endif -double d_mod(doublereal *x, doublereal *y) -#endif -{ -#ifdef IEEE_drem - double xa, ya, z; - if ((ya = *y) < 0.) - ya = -ya; - z = drem(xa = *x, ya); - if (xa > 0) { - if (z < 0) - z += ya; - } - else if (z > 0) - z -= ya; - return z; -#else - double quotient; - if( (quotient = *x / *y) >= 0) - quotient = floor(quotient); - else - quotient = -floor(-quotient); - return(*x - (*y) * quotient ); -#endif -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_nint.c b/ext/f2c_libs/d_nint.c deleted file mode 100644 index 66f2dd0ee..000000000 --- a/ext/f2c_libs/d_nint.c +++ /dev/null @@ -1,20 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double floor(); -double d_nint(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double d_nint(doublereal *x) -#endif -{ -return( (*x)>=0 ? - floor(*x + .5) : -floor(.5 - *x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_prod.c b/ext/f2c_libs/d_prod.c deleted file mode 100644 index f9f348b03..000000000 --- a/ext/f2c_libs/d_prod.c +++ /dev/null @@ -1,16 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -double d_prod(x,y) real *x, *y; -#else -double d_prod(real *x, real *y) -#endif -{ -return( (*x) * (*y) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_sign.c b/ext/f2c_libs/d_sign.c deleted file mode 100644 index d06e0d192..000000000 --- a/ext/f2c_libs/d_sign.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -double d_sign(a,b) doublereal *a, *b; -#else -double d_sign(doublereal *a, doublereal *b) -#endif -{ -double x; -x = (*a >= 0 ? *a : - *a); -return( *b >= 0 ? x : -x); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_sin.c b/ext/f2c_libs/d_sin.c deleted file mode 100644 index ebd4eec5e..000000000 --- a/ext/f2c_libs/d_sin.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double sin(); -double d_sin(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double d_sin(doublereal *x) -#endif -{ -return( sin(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_sinh.c b/ext/f2c_libs/d_sinh.c deleted file mode 100644 index 2479a6fab..000000000 --- a/ext/f2c_libs/d_sinh.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double sinh(); -double d_sinh(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double d_sinh(doublereal *x) -#endif -{ -return( sinh(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_sqrt.c b/ext/f2c_libs/d_sqrt.c deleted file mode 100644 index a7fa66c00..000000000 --- a/ext/f2c_libs/d_sqrt.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double sqrt(); -double d_sqrt(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double d_sqrt(doublereal *x) -#endif -{ -return( sqrt(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_tan.c b/ext/f2c_libs/d_tan.c deleted file mode 100644 index 7d252c4d5..000000000 --- a/ext/f2c_libs/d_tan.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double tan(); -double d_tan(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double d_tan(doublereal *x) -#endif -{ -return( tan(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/d_tanh.c b/ext/f2c_libs/d_tanh.c deleted file mode 100644 index 415b58508..000000000 --- a/ext/f2c_libs/d_tanh.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double tanh(); -double d_tanh(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double d_tanh(doublereal *x) -#endif -{ -return( tanh(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/dfe.c b/ext/f2c_libs/dfe.c deleted file mode 100644 index cd2e673d6..000000000 --- a/ext/f2c_libs/dfe.c +++ /dev/null @@ -1,151 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#include "fmt.h" -#ifdef __cplusplus -extern "C" { -#endif - - int -y_rsk(Void) -{ - if(f__curunit->uend || f__curunit->url <= f__recpos - || f__curunit->url == 1) return 0; - do { - getc(f__cf); - } while(++f__recpos < f__curunit->url); - return 0; -} - - int -y_getc(Void) -{ - int ch; - if(f__curunit->uend) return(-1); - if((ch=getc(f__cf))!=EOF) - { - f__recpos++; - if(f__curunit->url>=f__recpos || - f__curunit->url==1) - return(ch); - else return(' '); - } - if(feof(f__cf)) - { - f__curunit->uend=1; - errno=0; - return(-1); - } - err(f__elist->cierr,errno,"readingd"); -} - - static int -y_rev(Void) -{ - if (f__recpos < f__hiwater) - f__recpos = f__hiwater; - if (f__curunit->url > 1) - while(f__recpos < f__curunit->url) - (*f__putn)(' '); - if (f__recpos) - f__putbuf(0); - f__recpos = 0; - return(0); -} - - static int -y_err(Void) -{ - err(f__elist->cierr, 110, "dfe"); -} - - static int -y_newrec(Void) -{ - y_rev(); - f__hiwater = f__cursor = 0; - return(1); -} - - int -#ifdef KR_headers -c_dfe(a) cilist *a; -#else -c_dfe(cilist *a) -#endif -{ - f__sequential=0; - f__formatted=f__external=1; - f__elist=a; - f__cursor=f__scale=f__recpos=0; - f__curunit = &f__units[a->ciunit]; - if(a->ciunit>MXUNIT || a->ciunit<0) - err(a->cierr,101,"startchk"); - if(f__curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit)) - err(a->cierr,104,"dfe"); - f__cf=f__curunit->ufd; - if(!f__curunit->ufmt) err(a->cierr,102,"dfe") - if(!f__curunit->useek) err(a->cierr,104,"dfe") - f__fmtbuf=a->cifmt; - if(a->cirec <= 0) - err(a->cierr,130,"dfe") - FSEEK(f__cf,(OFF_T)f__curunit->url * (a->cirec-1),SEEK_SET); - f__curunit->uend = 0; - return(0); -} -#ifdef KR_headers -integer s_rdfe(a) cilist *a; -#else -integer s_rdfe(cilist *a) -#endif -{ - int n; - if(!f__init) f_init(); - f__reading=1; - if((n=c_dfe(a))) return(n); - if(f__curunit->uwrt && f__nowreading(f__curunit)) - err(a->cierr,errno,"read start"); - f__getn = y_getc; - f__doed = rd_ed; - f__doned = rd_ned; - f__dorevert = f__donewrec = y_err; - f__doend = y_rsk; - if(pars_f(f__fmtbuf)<0) - err(a->cierr,100,"read start"); - fmt_bg(); - return(0); -} -#ifdef KR_headers -integer s_wdfe(a) cilist *a; -#else -integer s_wdfe(cilist *a) -#endif -{ - int n; - if(!f__init) f_init(); - f__reading=0; - if((n=c_dfe(a))) return(n); - if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) - err(a->cierr,errno,"startwrt"); - f__putn = x_putc; - f__doed = w_ed; - f__doned= w_ned; - f__dorevert = y_err; - f__donewrec = y_newrec; - f__doend = y_rev; - if(pars_f(f__fmtbuf)<0) - err(a->cierr,100,"startwrt"); - fmt_bg(); - return(0); -} -integer e_rdfe(Void) -{ - en_fio(); - return 0; -} -integer e_wdfe(Void) -{ - return en_fio(); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/dolio.c b/ext/f2c_libs/dolio.c deleted file mode 100644 index 4070d8790..000000000 --- a/ext/f2c_libs/dolio.c +++ /dev/null @@ -1,26 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef __cplusplus -extern "C" { -#endif -#ifdef KR_headers -extern int (*f__lioproc)(); - -integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len; -#else -extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); - -integer do_lio(ftnint *type, ftnint *number, char *ptr, ftnlen len) -#endif -{ - return((*f__lioproc)(number,ptr,len,*type)); -} -#ifdef __cplusplus - } -#endif -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/dtime_.c b/ext/f2c_libs/dtime_.c deleted file mode 100644 index ccf681e0a..000000000 --- a/ext/f2c_libs/dtime_.c +++ /dev/null @@ -1,63 +0,0 @@ -#include "time.h" - -#if defined(MSDOS) || defined (__MINGW32__) -#undef USE_CLOCK -#define USE_CLOCK -#endif - -#ifndef REAL -#define REAL double -#endif - -#ifndef USE_CLOCK -#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ -#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ -#include "sys/types.h" -#include "sys/times.h" -#ifdef __cplusplus -extern "C" { -#endif -#endif - -#undef Hz -#ifdef CLK_TCK -#define Hz CLK_TCK -#else -#ifdef HZ -#define Hz HZ -#else -#define Hz 60 -#endif -#endif - - REAL -#ifdef KR_headers -dtime_(tarray) float *tarray; -#else -dtime_(float *tarray) -#endif -{ -#ifdef USE_CLOCK -#ifndef CLOCKS_PER_SECOND -#define CLOCKS_PER_SECOND Hz -#endif - static double t0; - double t = clock(); - tarray[1] = 0; - tarray[0] = (float) ((t - t0) / CLOCKS_PER_SECOND); - t0 = t; - return tarray[0]; -#else - struct tms t; - static struct tms t0; - - times(&t); - tarray[0] = (double)(t.tms_utime - t0.tms_utime) / Hz; - tarray[1] = (double)(t.tms_stime - t0.tms_stime) / Hz; - t0 = t; - return tarray[0] + tarray[1]; -#endif - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/due.c b/ext/f2c_libs/due.c deleted file mode 100644 index e463448f8..000000000 --- a/ext/f2c_libs/due.c +++ /dev/null @@ -1,77 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#ifdef __cplusplus -extern "C" { -#endif - - int -#ifdef KR_headers -c_due(a) cilist *a; -#else -c_due(cilist *a) -#endif -{ - if(!f__init) f_init(); - f__sequential=f__formatted=f__recpos=0; - f__external=1; - f__curunit = &f__units[a->ciunit]; - if(a->ciunit>=MXUNIT || a->ciunit<0) - err(a->cierr,101,"startio"); - f__elist=a; - if(f__curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due"); - f__cf=f__curunit->ufd; - if(f__curunit->ufmt) err(a->cierr,102,"cdue") - if(!f__curunit->useek) err(a->cierr,104,"cdue") - if(f__curunit->ufd==NULL) err(a->cierr,114,"cdue") - if(a->cirec <= 0) - err(a->cierr,130,"due") - FSEEK(f__cf,(OFF_T)(a->cirec-1)*f__curunit->url,SEEK_SET); - f__curunit->uend = 0; - return(0); -} -#ifdef KR_headers -integer s_rdue(a) cilist *a; -#else -integer s_rdue(cilist *a) -#endif -{ - int n; - f__reading=1; - if((n=c_due(a))) return(n); - if(f__curunit->uwrt && f__nowreading(f__curunit)) - err(a->cierr,errno,"read start"); - return(0); -} -#ifdef KR_headers -integer s_wdue(a) cilist *a; -#else -integer s_wdue(cilist *a) -#endif -{ - int n; - f__reading=0; - if((n=c_due(a))) return(n); - if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) - err(a->cierr,errno,"write start"); - return(0); -} -integer e_rdue(Void) -{ - if(f__curunit->url==1 || f__recpos==f__curunit->url) - return(0); - FSEEK(f__cf,(OFF_T)(f__curunit->url-f__recpos),SEEK_CUR); - if(FTELL(f__cf)%f__curunit->url) - err(f__elist->cierr,200,"syserr"); - return(0); -} -integer e_wdue(Void) -{ -#ifdef ALWAYS_FLUSH - if (fflush(f__cf)) - err(f__elist->cierr,errno,"write end"); -#endif - return(e_rdue()); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/ef1asc_.c b/ext/f2c_libs/ef1asc_.c deleted file mode 100644 index 70be0bc2e..000000000 --- a/ext/f2c_libs/ef1asc_.c +++ /dev/null @@ -1,25 +0,0 @@ -/* EFL support routine to copy string b to string a */ - -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - - -#define M ( (long) (sizeof(long) - 1) ) -#define EVEN(x) ( ( (x)+ M) & (~M) ) - -#ifdef KR_headers -extern VOID s_copy(); -ef1asc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb; -#else -extern void s_copy(char*,char*,ftnlen,ftnlen); -int ef1asc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) -#endif -{ -s_copy( (char *)a, (char *)b, EVEN(*la), *lb ); -return 0; /* ignored return value */ -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/ef1cmc_.c b/ext/f2c_libs/ef1cmc_.c deleted file mode 100644 index 4b420ae64..000000000 --- a/ext/f2c_libs/ef1cmc_.c +++ /dev/null @@ -1,20 +0,0 @@ -/* EFL support routine to compare two character strings */ - -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -extern integer s_cmp(); -integer ef1cmc_(a, la, b, lb) ftnint *a, *b; ftnlen *la, *lb; -#else -extern integer s_cmp(char*,char*,ftnlen,ftnlen); -integer ef1cmc_(ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) -#endif -{ -return( s_cmp( (char *)a, (char *)b, *la, *lb) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/endfile.c b/ext/f2c_libs/endfile.c deleted file mode 100644 index 8d7b7ea33..000000000 --- a/ext/f2c_libs/endfile.c +++ /dev/null @@ -1,160 +0,0 @@ -#include "f2c.h" -#include "fio.h" - -/* Compile this with -DNO_TRUNCATE if unistd.h does not exist or */ -/* if it does not define int truncate(const char *name, off_t). */ - -#ifdef MSDOS -#undef NO_TRUNCATE -#define NO_TRUNCATE -#endif - -#ifndef NO_TRUNCATE -#include "unistd.h" -#endif - -#ifdef KR_headers -extern char *strcpy(); -extern FILE *tmpfile(); -#else -#undef abs -#undef min -#undef max -#include "stdlib.h" -#include "string.h" -#ifdef __cplusplus -extern "C" { -#endif -#endif - -extern char *f__r_mode[], *f__w_mode[]; - -#ifdef KR_headers -integer f_end(a) alist *a; -#else -integer f_end(alist *a) -#endif -{ - unit *b; - FILE *tf; - - if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile"); - b = &f__units[a->aunit]; - if(b->ufd==NULL) { - char nbuf[10]; - sprintf(nbuf,"fort.%ld",(long)a->aunit); - if ((tf = FOPEN(nbuf, f__w_mode[0]))) - fclose(tf); - return(0); - } - b->uend=1; - return(b->useek ? t_runc(a) : 0); -} - -#ifdef NO_TRUNCATE - static int -#ifdef KR_headers -copy(from, len, to) FILE *from, *to; register long len; -#else -copy(FILE *from, register long len, FILE *to) -#endif -{ - int len1; - char buf[BUFSIZ]; - - while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) { - if (!fwrite(buf, len1, 1, to)) - return 1; - if ((len -= len1) <= 0) - break; - } - return 0; - } -#endif /* NO_TRUNCATE */ - - int -#ifdef KR_headers -t_runc(a) alist *a; -#else -t_runc(alist *a) -#endif -{ - OFF_T loc, len; - unit *b; - int rc; - FILE *bf; -#ifdef NO_TRUNCATE - FILE *tf; -#endif - - b = &f__units[a->aunit]; - if(b->url) - return(0); /*don't truncate direct files*/ - loc=FTELL(bf = b->ufd); - FSEEK(bf,(OFF_T)0,SEEK_END); - len=FTELL(bf); - if (loc >= len || b->useek == 0) - return(0); -#ifdef NO_TRUNCATE - if (b->ufnm == NULL) - return 0; - rc = 0; - fclose(b->ufd); - if (!loc) { - if (!(bf = FOPEN(b->ufnm, f__w_mode[b->ufmt]))) - rc = 1; - if (b->uwrt) - b->uwrt = 1; - goto done; - } - if (!(bf = FOPEN(b->ufnm, f__r_mode[0])) - || !(tf = tmpfile())) { -#ifdef NON_UNIX_STDIO - bad: -#endif - rc = 1; - goto done; - } - if (copy(bf, (long)loc, tf)) { - bad1: - rc = 1; - goto done1; - } - if (!(bf = FREOPEN(b->ufnm, f__w_mode[0], bf))) - goto bad1; - rewind(tf); - if (copy(tf, (long)loc, bf)) - goto bad1; - b->uwrt = 1; - b->urw = 2; -#ifdef NON_UNIX_STDIO - if (b->ufmt) { - fclose(bf); - if (!(bf = FOPEN(b->ufnm, f__w_mode[3]))) - goto bad; - FSEEK(bf,(OFF_T)0,SEEK_END); - b->urw = 3; - } -#endif -done1: - fclose(tf); -done: - f__cf = b->ufd = bf; -#else /* NO_TRUNCATE */ - if (b->urw & 2) - fflush(b->ufd); /* necessary on some Linux systems */ -#ifndef FTRUNCATE -#define FTRUNCATE ftruncate -#endif - rc = FTRUNCATE(fileno(b->ufd), loc); - /* The following FSEEK is unnecessary on some systems, */ - /* but should be harmless. */ - FSEEK(b->ufd, (OFF_T)0, SEEK_END); -#endif /* NO_TRUNCATE */ - if (rc) - err(a->aerr,111,"endfile"); - return 0; - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/err.c b/ext/f2c_libs/err.c deleted file mode 100644 index 4960c282b..000000000 --- a/ext/f2c_libs/err.c +++ /dev/null @@ -1,291 +0,0 @@ -#include "sysdep1.h" /* here to get stat64 on some badly designed Linux systems */ -#include "f2c.h" -#ifdef KR_headers -extern char *malloc(); -#else -#undef abs -#undef min -#undef max -#include "stdlib.h" -#endif -#include "fio.h" -#include "fmt.h" /* for struct syl */ - -#ifndef NON_POSIX_STDIO -#ifdef MSDOS -#include "io.h" -#else -#include "unistd.h" /* for access */ -#endif -#endif - -#ifdef __cplusplus -extern "C" { -#endif - -/*global definitions*/ -unit f__units[MXUNIT]; /*unit table*/ -flag f__init; /*0 on entry, 1 after initializations*/ -cilist *f__elist; /*active external io list*/ -icilist *f__svic; /*active internal io list*/ -flag f__reading; /*1 if reading, 0 if writing*/ -flag f__cplus,f__cblank; -char *f__fmtbuf; -flag f__external; /*1 if external io, 0 if internal */ -#ifdef KR_headers -int (*f__doed)(),(*f__doned)(); -int (*f__doend)(),(*f__donewrec)(),(*f__dorevert)(); -int (*f__getn)(); /* for formatted input */ -void (*f__putn)(); /* for formatted output */ -#else -int (*f__getn)(void); /* for formatted input */ -void (*f__putn)(int); /* for formatted output */ -int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); -int (*f__dorevert)(void),(*f__donewrec)(void),(*f__doend)(void); -#endif -flag f__sequential; /*1 if sequential io, 0 if direct*/ -flag f__formatted; /*1 if formatted io, 0 if unformatted*/ -FILE *f__cf; /*current file*/ -unit *f__curunit; /*current unit*/ -int f__recpos; /*place in current record*/ -OFF_T f__cursor, f__hiwater; -int f__scale; -char *f__icptr; - -/*error messages*/ -static char *F_err[] = -{ - "error in format", /* 100 */ - "illegal unit number", /* 101 */ - "formatted io not allowed", /* 102 */ - "unformatted io not allowed", /* 103 */ - "direct io not allowed", /* 104 */ - "sequential io not allowed", /* 105 */ - "can't backspace file", /* 106 */ - "null file name", /* 107 */ - "can't stat file", /* 108 */ - "unit not connected", /* 109 */ - "off end of record", /* 110 */ - "truncation failed in endfile", /* 111 */ - "incomprehensible list input", /* 112 */ - "out of free space", /* 113 */ - "unit not connected", /* 114 */ - "read unexpected character", /* 115 */ - "bad logical input field", /* 116 */ - "bad variable type", /* 117 */ - "bad namelist name", /* 118 */ - "variable not in namelist", /* 119 */ - "no end record", /* 120 */ - "variable count incorrect", /* 121 */ - "subscript for scalar variable", /* 122 */ - "invalid array section", /* 123 */ - "substring out of bounds", /* 124 */ - "subscript out of bounds", /* 125 */ - "can't read file", /* 126 */ - "can't write file", /* 127 */ - "'new' file exists", /* 128 */ - "can't append to file", /* 129 */ - "non-positive record number", /* 130 */ - "nmLbuf overflow" /* 131 */ -}; -#define MAXERR (sizeof(F_err)/sizeof(char *)+100) - - int -#ifdef KR_headers -f__canseek(f) FILE *f; /*SYSDEP*/ -#else -f__canseek(FILE *f) /*SYSDEP*/ -#endif -{ -#ifdef NON_UNIX_STDIO - return !ISATTY(FILENO(f)); -#else - struct STAT_ST x; - - if (FSTAT(FILENO(f),&x) < 0) - return(0); -#ifdef S_IFMT - switch(x.st_mode & S_IFMT) { - case S_IFDIR: - case S_IFREG: - if(x.st_nlink > 0) /* !pipe */ - return(1); - else - return(0); - case S_IFCHR: - if(ISATTY(FILENO(f))) - return(0); - return(1); -#ifdef S_IFBLK - case S_IFBLK: - return(1); -#endif - } -#else -#ifdef S_ISDIR - /* POSIX version */ - if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) { - if(x.st_nlink > 0) /* !pipe */ - return(1); - else - return(0); - } - if (S_ISCHR(x.st_mode)) { - if(ISATTY(FILENO(f))) - return(0); - return(1); - } - if (S_ISBLK(x.st_mode)) - return(1); -#else - Help! How does fstat work on this system? -#endif -#endif - return(0); /* who knows what it is? */ -#endif -} - - void -#ifdef KR_headers -f__fatal(n,s) char *s; -#else -f__fatal(int n, char *s) -#endif -{ - if(n<100 && n>=0) perror(s); /*SYSDEP*/ - else if(n >= (int)MAXERR || n < -1) - { fprintf(stderr,"%s: illegal error number %d\n",s,n); - } - else if(n == -1) fprintf(stderr,"%s: end of file\n",s); - else - fprintf(stderr,"%s: %s\n",s,F_err[n-100]); - if (f__curunit) { - fprintf(stderr,"apparent state: unit %d ", - (int)(f__curunit-f__units)); - fprintf(stderr, f__curunit->ufnm ? "named %s\n" : "(unnamed)\n", - f__curunit->ufnm); - } - else - fprintf(stderr,"apparent state: internal I/O\n"); - if (f__fmtbuf) - fprintf(stderr,"last format: %s\n",f__fmtbuf); - fprintf(stderr,"lately %s %s %s %s",f__reading?"reading":"writing", - f__sequential?"sequential":"direct",f__formatted?"formatted":"unformatted", - f__external?"external":"internal"); - sig_die(" IO", 1); -} -/*initialization routine*/ - VOID -f_init(Void) -{ unit *p; - - f__init=1; - p= &f__units[0]; - p->ufd=stderr; - p->useek=f__canseek(stderr); - p->ufmt=1; - p->uwrt=1; - p = &f__units[5]; - p->ufd=stdin; - p->useek=f__canseek(stdin); - p->ufmt=1; - p->uwrt=0; - p= &f__units[6]; - p->ufd=stdout; - p->useek=f__canseek(stdout); - p->ufmt=1; - p->uwrt=1; -} - - int -#ifdef KR_headers -f__nowreading(x) unit *x; -#else -f__nowreading(unit *x) -#endif -{ - OFF_T loc; - int ufmt, urw; - extern char *f__r_mode[], *f__w_mode[]; - - if (x->urw & 1) - goto done; - if (!x->ufnm) - goto cantread; - ufmt = x->url ? 0 : x->ufmt; - loc = FTELL(x->ufd); - urw = 3; - if (!FREOPEN(x->ufnm, f__w_mode[ufmt|2], x->ufd)) { - urw = 1; - if(!FREOPEN(x->ufnm, f__r_mode[ufmt], x->ufd)) { - cantread: - errno = 126; - return 1; - } - } - FSEEK(x->ufd,loc,SEEK_SET); - x->urw = urw; - done: - x->uwrt = 0; - return 0; -} - - int -#ifdef KR_headers -f__nowwriting(x) unit *x; -#else -f__nowwriting(unit *x) -#endif -{ - OFF_T loc; - int ufmt; - extern char *f__w_mode[]; - - if (x->urw & 2) { - if (x->urw & 1) - FSEEK(x->ufd, (OFF_T)0, SEEK_CUR); - goto done; - } - if (!x->ufnm) - goto cantwrite; - ufmt = x->url ? 0 : x->ufmt; - if (x->uwrt == 3) { /* just did write, rewind */ - if (!(f__cf = x->ufd = - FREOPEN(x->ufnm,f__w_mode[ufmt],x->ufd))) - goto cantwrite; - x->urw = 2; - } - else { - loc=FTELL(x->ufd); - if (!(f__cf = x->ufd = - FREOPEN(x->ufnm, f__w_mode[ufmt | 2], x->ufd))) - { - x->ufd = NULL; - cantwrite: - errno = 127; - return(1); - } - x->urw = 3; - FSEEK(x->ufd,loc,SEEK_SET); - } - done: - x->uwrt = 1; - return 0; -} - - int -#ifdef KR_headers -err__fl(f, m, s) int f, m; char *s; -#else -err__fl(int f, int m, char *s) -#endif -{ - if (!f) - f__fatal(m, s); - if (f__doend) - (*f__doend)(); - return errno = m; - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/etime_.c b/ext/f2c_libs/etime_.c deleted file mode 100644 index 6f559a686..000000000 --- a/ext/f2c_libs/etime_.c +++ /dev/null @@ -1,58 +0,0 @@ -#include "time.h" - -#if defined(MSDOS) || defined (__MINGW32__) -#undef USE_CLOCK -#define USE_CLOCK -#endif - -#ifndef REAL -#define REAL double -#endif - -#ifndef USE_CLOCK -#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ -#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ -#include "sys/types.h" -#include "sys/times.h" -#ifdef __cplusplus -extern "C" { -#endif -#endif - -#undef Hz -#ifdef CLK_TCK -#define Hz CLK_TCK -#else -#ifdef HZ -#define Hz HZ -#else -#define Hz 60 -#endif -#endif - - REAL -#ifdef KR_headers -etime_(tarray) float *tarray; -#else -etime_(float *tarray) -#endif -{ -#ifdef USE_CLOCK -#ifndef CLOCKS_PER_SECOND -#define CLOCKS_PER_SECOND Hz -#endif - double t = clock(); - tarray[1] = 0; - tarray[0] = (float) (t / CLOCKS_PER_SECOND); - return tarray[0]; -#else - struct tms t; - - times(&t); - return (tarray[0] = (double)t.tms_utime/Hz) - + (tarray[1] = (double)t.tms_stime/Hz); -#endif - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/exit_.c b/ext/f2c_libs/exit_.c deleted file mode 100644 index 08e9d0706..000000000 --- a/ext/f2c_libs/exit_.c +++ /dev/null @@ -1,43 +0,0 @@ -/* This gives the effect of - - subroutine exit(rc) - integer*4 rc - stop - end - - * with the added side effect of supplying rc as the program's exit code. - */ - -#include "f2c.h" -#undef abs -#undef min -#undef max -#ifndef KR_headers -#include "stdlib.h" -#ifdef __cplusplus -extern "C" { -#endif -#ifdef __cplusplus -extern "C" { -#endif -extern void f_exit(void); -#endif - - void -#ifdef KR_headers -exit_(rc) integer *rc; -#else -exit_(integer *rc) -#endif -{ -#ifdef NO_ONEXIT - f_exit(); -#endif - exit(*rc); - } -#ifdef __cplusplus -} -#endif -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/f2c.h b/ext/f2c_libs/f2c.h deleted file mode 100644 index af75d6d1f..000000000 --- a/ext/f2c_libs/f2c.h +++ /dev/null @@ -1,246 +0,0 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - -//#define -#ifdef _WIN32 -#include /* for real isatty() */ -/* - * Need the following definition so that MS math.h doesn't redefine the structure - * complex to be two doubles. f2c defines the structure complex to be 2 reals, - * and the structure doublecomplex to be 2 doubles. - */ -#define _COMPLEX_DEFINED -typedef __int64 longint; -typedef __int64 ulongint; /* HACK ALERT */ -#endif - -//typedef long int integer; -typedef int integer; -//typedef unsigned long int uinteger; -typedef unsigned int uinteger; -typedef char *address; -typedef short int shortint; -typedef float real; -typedef double doublereal; -typedef struct { real r, i; } complex; -typedef struct { doublereal r, i; } doublecomplex; -//typedef long int logical; -typedef int logical; -typedef short int shortlogical; -typedef char logical1; -typedef char integer1; -#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ -typedef long long longint; /* system-dependent */ -typedef unsigned long long ulongint; /* system-dependent */ -#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) -#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) -#endif - -#define TRUE_ (1) -#define FALSE_ (0) - -/* Extern is for use with -E */ -#ifndef Extern -#define Extern extern -#endif - -/* I/O stuff */ - -#ifdef f2c_i2 -/* for -i2 */ -typedef short flag; -typedef short ftnlen; -typedef short ftnint; -#else -//typedef long int flag; -//typedef long int ftnlen; -//typedef long int ftnint; -typedef int flag; -typedef int ftnlen; -typedef int ftnint; -#endif - -/*external read, write*/ -typedef struct -{ flag cierr; - ftnint ciunit; - flag ciend; - char *cifmt; - ftnint cirec; -} cilist; - -/*internal read, write*/ -typedef struct -{ flag icierr; - char *iciunit; - flag iciend; - char *icifmt; - ftnint icirlen; - ftnint icirnum; -} icilist; - -/*open*/ -typedef struct -{ flag oerr; - ftnint ounit; - char *ofnm; - ftnlen ofnmlen; - char *osta; - char *oacc; - char *ofm; - ftnint orl; - char *oblnk; -} olist; - -/*close*/ -typedef struct -{ flag cerr; - ftnint cunit; - char *csta; -} cllist; - -/*rewind, backspace, endfile*/ -typedef struct -{ flag aerr; - ftnint aunit; -} alist; - -/* inquire */ -typedef struct -{ flag inerr; - ftnint inunit; - char *infile; - ftnlen infilen; - ftnint *inex; /*parameters in standard's order*/ - ftnint *inopen; - ftnint *innum; - ftnint *innamed; - char *inname; - ftnlen innamlen; - char *inacc; - ftnlen inacclen; - char *inseq; - ftnlen inseqlen; - char *indir; - ftnlen indirlen; - char *infmt; - ftnlen infmtlen; - char *inform; - ftnint informlen; - char *inunf; - ftnlen inunflen; - ftnint *inrecl; - ftnint *innrec; - char *inblank; - ftnlen inblanklen; -} inlist; - -#define VOID void - -union Multitype { /* for multiple entry points */ - integer1 g; - shortint h; - integer i; - /* longint j; */ - real r; - doublereal d; - complex c; - doublecomplex z; - }; - -typedef union Multitype Multitype; - -/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ - -struct Vardesc { /* for Namelist */ - char *name; - char *addr; - ftnlen *dims; - int type; - }; -typedef struct Vardesc Vardesc; - -struct Namelist { - char *name; - Vardesc **vars; - int nvars; - }; -typedef struct Namelist Namelist; - -#define abs(x) ((x) >= 0 ? (x) : -(x)) -#define dabs(x) (doublereal)abs(x) -#ifndef min -#define min(a,b) ((a) <= (b) ? (a) : (b)) -#endif -#ifndef max -#define max(a,b) ((a) >= (b) ? (a) : (b)) -#endif -#define dmin(a,b) (doublereal)min(a,b) -#define dmax(a,b) (doublereal)max(a,b) -#define bit_test(a,b) ((a) >> (b) & 1) -#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) -#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) - -/* procedure parameter types for -A and -C++ */ - -#define F2C_proc_par_types 1 -#ifdef __cplusplus -typedef int /* Unknown procedure type */ (*U_fp)(...); -typedef shortint (*J_fp)(...); -typedef integer (*I_fp)(...); -typedef real (*R_fp)(...); -typedef doublereal (*D_fp)(...), (*E_fp)(...); -typedef /* Complex */ VOID (*C_fp)(...); -typedef /* Double Complex */ VOID (*Z_fp)(...); -typedef logical (*L_fp)(...); -typedef shortlogical (*K_fp)(...); -typedef /* Character */ VOID (*H_fp)(...); -typedef /* Subroutine */ int (*S_fp)(...); -#else -typedef int /* Unknown procedure type */ (*U_fp)(); -typedef shortint (*J_fp)(); -typedef integer (*I_fp)(); -typedef real (*R_fp)(); -typedef doublereal (*D_fp)(), (*E_fp)(); -typedef /* Complex */ VOID (*C_fp)(); -typedef /* Double Complex */ VOID (*Z_fp)(); -typedef logical (*L_fp)(); -typedef shortlogical (*K_fp)(); -typedef /* Character */ VOID (*H_fp)(); -typedef /* Subroutine */ int (*S_fp)(); -#endif -/* E_fp is for real functions when -R is not specified */ -typedef VOID C_f; /* complex function */ -typedef VOID H_f; /* character function */ -typedef VOID Z_f; /* double complex function */ -typedef doublereal E_f; /* real function with -R not specified */ - -/* undef any lower-case symbols that your C compiler predefines, e.g.: */ - -#ifndef Skip_f2c_Undefs -#undef cray -#undef gcos -#undef mc68010 -#undef mc68020 -#undef mips -#undef pdp11 -#undef sgi -#undef sparc -#undef sun -#undef sun2 -#undef sun3 -#undef sun4 -#undef u370 -#undef u3b -#undef u3b2 -#undef u3b5 -#undef unix -#undef vax -#endif -#endif diff --git a/ext/f2c_libs/f2c.h0 b/ext/f2c_libs/f2c.h0 deleted file mode 100644 index af75d6d1f..000000000 --- a/ext/f2c_libs/f2c.h0 +++ /dev/null @@ -1,246 +0,0 @@ -/* f2c.h -- Standard Fortran to C header file */ - -/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." - - - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ - -#ifndef F2C_INCLUDE -#define F2C_INCLUDE - -//#define -#ifdef _WIN32 -#include /* for real isatty() */ -/* - * Need the following definition so that MS math.h doesn't redefine the structure - * complex to be two doubles. f2c defines the structure complex to be 2 reals, - * and the structure doublecomplex to be 2 doubles. - */ -#define _COMPLEX_DEFINED -typedef __int64 longint; -typedef __int64 ulongint; /* HACK ALERT */ -#endif - -//typedef long int integer; -typedef int integer; -//typedef unsigned long int uinteger; -typedef unsigned int uinteger; -typedef char *address; -typedef short int shortint; -typedef float real; -typedef double doublereal; -typedef struct { real r, i; } complex; -typedef struct { doublereal r, i; } doublecomplex; -//typedef long int logical; -typedef int logical; -typedef short int shortlogical; -typedef char logical1; -typedef char integer1; -#ifdef INTEGER_STAR_8 /* Adjust for integer*8. */ -typedef long long longint; /* system-dependent */ -typedef unsigned long long ulongint; /* system-dependent */ -#define qbit_clear(a,b) ((a) & ~((ulongint)1 << (b))) -#define qbit_set(a,b) ((a) | ((ulongint)1 << (b))) -#endif - -#define TRUE_ (1) -#define FALSE_ (0) - -/* Extern is for use with -E */ -#ifndef Extern -#define Extern extern -#endif - -/* I/O stuff */ - -#ifdef f2c_i2 -/* for -i2 */ -typedef short flag; -typedef short ftnlen; -typedef short ftnint; -#else -//typedef long int flag; -//typedef long int ftnlen; -//typedef long int ftnint; -typedef int flag; -typedef int ftnlen; -typedef int ftnint; -#endif - -/*external read, write*/ -typedef struct -{ flag cierr; - ftnint ciunit; - flag ciend; - char *cifmt; - ftnint cirec; -} cilist; - -/*internal read, write*/ -typedef struct -{ flag icierr; - char *iciunit; - flag iciend; - char *icifmt; - ftnint icirlen; - ftnint icirnum; -} icilist; - -/*open*/ -typedef struct -{ flag oerr; - ftnint ounit; - char *ofnm; - ftnlen ofnmlen; - char *osta; - char *oacc; - char *ofm; - ftnint orl; - char *oblnk; -} olist; - -/*close*/ -typedef struct -{ flag cerr; - ftnint cunit; - char *csta; -} cllist; - -/*rewind, backspace, endfile*/ -typedef struct -{ flag aerr; - ftnint aunit; -} alist; - -/* inquire */ -typedef struct -{ flag inerr; - ftnint inunit; - char *infile; - ftnlen infilen; - ftnint *inex; /*parameters in standard's order*/ - ftnint *inopen; - ftnint *innum; - ftnint *innamed; - char *inname; - ftnlen innamlen; - char *inacc; - ftnlen inacclen; - char *inseq; - ftnlen inseqlen; - char *indir; - ftnlen indirlen; - char *infmt; - ftnlen infmtlen; - char *inform; - ftnint informlen; - char *inunf; - ftnlen inunflen; - ftnint *inrecl; - ftnint *innrec; - char *inblank; - ftnlen inblanklen; -} inlist; - -#define VOID void - -union Multitype { /* for multiple entry points */ - integer1 g; - shortint h; - integer i; - /* longint j; */ - real r; - doublereal d; - complex c; - doublecomplex z; - }; - -typedef union Multitype Multitype; - -/*typedef long int Long;*/ /* No longer used; formerly in Namelist */ - -struct Vardesc { /* for Namelist */ - char *name; - char *addr; - ftnlen *dims; - int type; - }; -typedef struct Vardesc Vardesc; - -struct Namelist { - char *name; - Vardesc **vars; - int nvars; - }; -typedef struct Namelist Namelist; - -#define abs(x) ((x) >= 0 ? (x) : -(x)) -#define dabs(x) (doublereal)abs(x) -#ifndef min -#define min(a,b) ((a) <= (b) ? (a) : (b)) -#endif -#ifndef max -#define max(a,b) ((a) >= (b) ? (a) : (b)) -#endif -#define dmin(a,b) (doublereal)min(a,b) -#define dmax(a,b) (doublereal)max(a,b) -#define bit_test(a,b) ((a) >> (b) & 1) -#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) -#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) - -/* procedure parameter types for -A and -C++ */ - -#define F2C_proc_par_types 1 -#ifdef __cplusplus -typedef int /* Unknown procedure type */ (*U_fp)(...); -typedef shortint (*J_fp)(...); -typedef integer (*I_fp)(...); -typedef real (*R_fp)(...); -typedef doublereal (*D_fp)(...), (*E_fp)(...); -typedef /* Complex */ VOID (*C_fp)(...); -typedef /* Double Complex */ VOID (*Z_fp)(...); -typedef logical (*L_fp)(...); -typedef shortlogical (*K_fp)(...); -typedef /* Character */ VOID (*H_fp)(...); -typedef /* Subroutine */ int (*S_fp)(...); -#else -typedef int /* Unknown procedure type */ (*U_fp)(); -typedef shortint (*J_fp)(); -typedef integer (*I_fp)(); -typedef real (*R_fp)(); -typedef doublereal (*D_fp)(), (*E_fp)(); -typedef /* Complex */ VOID (*C_fp)(); -typedef /* Double Complex */ VOID (*Z_fp)(); -typedef logical (*L_fp)(); -typedef shortlogical (*K_fp)(); -typedef /* Character */ VOID (*H_fp)(); -typedef /* Subroutine */ int (*S_fp)(); -#endif -/* E_fp is for real functions when -R is not specified */ -typedef VOID C_f; /* complex function */ -typedef VOID H_f; /* character function */ -typedef VOID Z_f; /* double complex function */ -typedef doublereal E_f; /* real function with -R not specified */ - -/* undef any lower-case symbols that your C compiler predefines, e.g.: */ - -#ifndef Skip_f2c_Undefs -#undef cray -#undef gcos -#undef mc68010 -#undef mc68020 -#undef mips -#undef pdp11 -#undef sgi -#undef sparc -#undef sun -#undef sun2 -#undef sun3 -#undef sun4 -#undef u370 -#undef u3b -#undef u3b2 -#undef u3b5 -#undef unix -#undef vax -#endif -#endif diff --git a/ext/f2c_libs/f2ch.add b/ext/f2c_libs/f2ch.add deleted file mode 100644 index a2acc17a1..000000000 --- a/ext/f2c_libs/f2ch.add +++ /dev/null @@ -1,162 +0,0 @@ -/* If you are using a C++ compiler, append the following to f2c.h - for compiling libF77 and libI77. */ - -#ifdef __cplusplus -extern "C" { -extern int abort_(void); -extern double c_abs(complex *); -extern void c_cos(complex *, complex *); -extern void c_div(complex *, complex *, complex *); -extern void c_exp(complex *, complex *); -extern void c_log(complex *, complex *); -extern void c_sin(complex *, complex *); -extern void c_sqrt(complex *, complex *); -extern double d_abs(double *); -extern double d_acos(double *); -extern double d_asin(double *); -extern double d_atan(double *); -extern double d_atn2(double *, double *); -extern void d_cnjg(doublecomplex *, doublecomplex *); -extern double d_cos(double *); -extern double d_cosh(double *); -extern double d_dim(double *, double *); -extern double d_exp(double *); -extern double d_imag(doublecomplex *); -extern double d_int(double *); -extern double d_lg10(double *); -extern double d_log(double *); -extern double d_mod(double *, double *); -extern double d_nint(double *); -extern double d_prod(float *, float *); -extern double d_sign(double *, double *); -extern double d_sin(double *); -extern double d_sinh(double *); -extern double d_sqrt(double *); -extern double d_tan(double *); -extern double d_tanh(double *); -extern double derf_(double *); -extern double derfc_(double *); -extern integer do_fio(ftnint *, char *, ftnlen); -extern integer do_lio(ftnint *, ftnint *, char *, ftnlen); -extern integer do_uio(ftnint *, char *, ftnlen); -extern integer e_rdfe(void); -extern integer e_rdue(void); -extern integer e_rsfe(void); -extern integer e_rsfi(void); -extern integer e_rsle(void); -extern integer e_rsli(void); -extern integer e_rsue(void); -extern integer e_wdfe(void); -extern integer e_wdue(void); -extern integer e_wsfe(void); -extern integer e_wsfi(void); -extern integer e_wsle(void); -extern integer e_wsli(void); -extern integer e_wsue(void); -extern int ef1asc_(ftnint *, ftnlen *, ftnint *, ftnlen *); -extern integer ef1cmc_(ftnint *, ftnlen *, ftnint *, ftnlen *); -extern double erf(double); -extern double erf_(float *); -extern double erfc(double); -extern double erfc_(float *); -extern integer f_back(alist *); -extern integer f_clos(cllist *); -extern integer f_end(alist *); -extern void f_exit(void); -extern integer f_inqu(inlist *); -extern integer f_open(olist *); -extern integer f_rew(alist *); -extern int flush_(void); -extern void getarg_(integer *, char *, ftnlen); -extern void getenv_(char *, char *, ftnlen, ftnlen); -extern short h_abs(short *); -extern short h_dim(short *, short *); -extern short h_dnnt(double *); -extern short h_indx(char *, char *, ftnlen, ftnlen); -extern short h_len(char *, ftnlen); -extern short h_mod(short *, short *); -extern short h_nint(float *); -extern short h_sign(short *, short *); -extern short hl_ge(char *, char *, ftnlen, ftnlen); -extern short hl_gt(char *, char *, ftnlen, ftnlen); -extern short hl_le(char *, char *, ftnlen, ftnlen); -extern short hl_lt(char *, char *, ftnlen, ftnlen); -extern integer i_abs(integer *); -extern integer i_dim(integer *, integer *); -extern integer i_dnnt(double *); -extern integer i_indx(char *, char *, ftnlen, ftnlen); -extern integer i_len(char *, ftnlen); -extern integer i_mod(integer *, integer *); -extern integer i_nint(float *); -extern integer i_sign(integer *, integer *); -extern integer iargc_(void); -extern ftnlen l_ge(char *, char *, ftnlen, ftnlen); -extern ftnlen l_gt(char *, char *, ftnlen, ftnlen); -extern ftnlen l_le(char *, char *, ftnlen, ftnlen); -extern ftnlen l_lt(char *, char *, ftnlen, ftnlen); -extern void pow_ci(complex *, complex *, integer *); -extern double pow_dd(double *, double *); -extern double pow_di(double *, integer *); -extern short pow_hh(short *, shortint *); -extern integer pow_ii(integer *, integer *); -extern double pow_ri(float *, integer *); -extern void pow_zi(doublecomplex *, doublecomplex *, integer *); -extern void pow_zz(doublecomplex *, doublecomplex *, doublecomplex *); -extern double r_abs(float *); -extern double r_acos(float *); -extern double r_asin(float *); -extern double r_atan(float *); -extern double r_atn2(float *, float *); -extern void r_cnjg(complex *, complex *); -extern double r_cos(float *); -extern double r_cosh(float *); -extern double r_dim(float *, float *); -extern double r_exp(float *); -extern double r_imag(complex *); -extern double r_int(float *); -extern double r_lg10(float *); -extern double r_log(float *); -extern double r_mod(float *, float *); -extern double r_nint(float *); -extern double r_sign(float *, float *); -extern double r_sin(float *); -extern double r_sinh(float *); -extern double r_sqrt(float *); -extern double r_tan(float *); -extern double r_tanh(float *); -extern void s_cat(char *, char **, integer *, integer *, ftnlen); -extern integer s_cmp(char *, char *, ftnlen, ftnlen); -extern void s_copy(char *, char *, ftnlen, ftnlen); -extern int s_paus(char *, ftnlen); -extern integer s_rdfe(cilist *); -extern integer s_rdue(cilist *); -extern integer s_rnge(char *, integer, char *, integer); -extern integer s_rsfe(cilist *); -extern integer s_rsfi(icilist *); -extern integer s_rsle(cilist *); -extern integer s_rsli(icilist *); -extern integer s_rsne(cilist *); -extern integer s_rsni(icilist *); -extern integer s_rsue(cilist *); -extern int s_stop(char *, ftnlen); -extern integer s_wdfe(cilist *); -extern integer s_wdue(cilist *); -extern integer s_wsfe(cilist *); -extern integer s_wsfi(icilist *); -extern integer s_wsle(cilist *); -extern integer s_wsli(icilist *); -extern integer s_wsne(cilist *); -extern integer s_wsni(icilist *); -extern integer s_wsue(cilist *); -extern void sig_die(char *, int); -extern integer signal_(integer *, void (*)(int)); -extern integer system_(char *, ftnlen); -extern double z_abs(doublecomplex *); -extern void z_cos(doublecomplex *, doublecomplex *); -extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *); -extern void z_exp(doublecomplex *, doublecomplex *); -extern void z_log(doublecomplex *, doublecomplex *); -extern void z_sin(doublecomplex *, doublecomplex *); -extern void z_sqrt(doublecomplex *, doublecomplex *); - } -#endif diff --git a/ext/f2c_libs/f77_aloc.c b/ext/f2c_libs/f77_aloc.c deleted file mode 100644 index 1ff0f896b..000000000 --- a/ext/f2c_libs/f77_aloc.c +++ /dev/null @@ -1,44 +0,0 @@ -#include "f2c.h" -#undef abs -#undef min -#undef max -#include "stdio.h" - -static integer memfailure = 3; - -#ifdef KR_headers -extern char *malloc(); -extern void exit_(); - - char * -F77_aloc(Len, whence) integer Len; char *whence; -#else -#include "stdlib.h" -#ifdef __cplusplus -extern "C" { -#endif -#ifdef __cplusplus -extern "C" { -#endif -extern void exit_(integer*); -#ifdef __cplusplus - } -#endif - - char * -F77_aloc(integer Len, char *whence) -#endif -{ - char *rv; - unsigned int uLen = (unsigned int) Len; /* for K&R C */ - - if (!(rv = (char*)malloc(uLen))) { - fprintf(stderr, "malloc(%u) failure in %s\n", - uLen, whence); - exit_(&memfailure); - } - return rv; - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/f77vers.c b/ext/f2c_libs/f77vers.c deleted file mode 100644 index 782d40160..000000000 --- a/ext/f2c_libs/f77vers.c +++ /dev/null @@ -1,93 +0,0 @@ - char -_libf77_version_f2c[] = "\n@(#) LIBF77 VERSION (f2c) 20021004\n"; - -/* -2.00 11 June 1980. File version.c added to library. -2.01 31 May 1988. s_paus() flushes stderr; names of hl_* fixed - [ d]erf[c ] added - 8 Aug. 1989: #ifdefs for f2c -i2 added to s_cat.c - 29 Nov. 1989: s_cmp returns long (for f2c) - 30 Nov. 1989: arg types from f2c.h - 12 Dec. 1989: s_rnge allows long names - 19 Dec. 1989: getenv_ allows unsorted environment - 28 Mar. 1990: add exit(0) to end of main() - 2 Oct. 1990: test signal(...) == SIG_IGN rather than & 01 in main - 17 Oct. 1990: abort() calls changed to sig_die(...,1) - 22 Oct. 1990: separate sig_die from main - 25 Apr. 1991: minor, theoretically invisible tweaks to s_cat, sig_die - 31 May 1991: make system_ return status - 18 Dec. 1991: change long to ftnlen (for -i2) many places - 28 Feb. 1992: repair z_sqrt.c (scribbled on input, gave wrong answer) - 18 July 1992: for n < 0, repair handling of 0**n in pow_[dr]i.c - and m**n in pow_hh.c and pow_ii.c; - catch SIGTRAP in main() for error msg before abort - 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined - 23 Oct. 1992: fix botch in signal_.c (erroneous deref of 2nd arg); - change Cabs to f__cabs. - 12 March 1993: various tweaks for C++ - 2 June 1994: adjust so abnormal terminations invoke f_exit just once - 16 Sept. 1994: s_cmp: treat characters as unsigned in comparisons. - 19 Sept. 1994: s_paus: flush after end of PAUSE; add -DMSDOS - 12 Jan. 1995: pow_[dhiqrz][hiq]: adjust x**i to work on machines - that sign-extend right shifts when i is the most - negative integer. - 26 Jan. 1995: adjust s_cat.c, s_copy.c to permit the left-hand side - of character assignments to appear on the right-hand - side (unless compiled with -DNO_OVERWRITE). - 27 Jan. 1995: minor tweak to s_copy.c: copy forward whenever - possible (for better cache behavior). - 30 May 1995: added subroutine exit(rc) integer rc. Version not changed. - 29 Aug. 1995: add F77_aloc.c; use it in s_cat.c and system_.c. - 6 Sept. 1995: fix return type of system_ under -DKR_headers. - 19 Dec. 1995: s_cat.c: fix bug when 2nd or later arg overlaps lhs. - 19 Mar. 1996: s_cat.c: supply missing break after overlap detection. - 13 May 1996: add [lq]bitbits.c and [lq]bitshft.c (f90 bit intrinsics). - 19 June 1996: add casts to unsigned in [lq]bitshft.c. - 26 Feb. 1997: adjust functions with a complex output argument - to permit aliasing it with input arguments. - (For now, at least, this is just for possible - benefit of g77.) - 4 April 1997: [cz]_div.c: tweaks invisible on most systems (that may - affect systems using gratuitous extra precision). - 19 Sept. 1997: [de]time_.c (Unix systems only): change return - type to double. - 2 May 1999: getenv_.c: omit environ in favor of getenv(). - c_cos.c, c_exp.c, c_sin.c, d_cnjg.c, r_cnjg.c, - z_cos.c, z_exp.c, z_log.c, z_sin.c: cope fully with - overlapping arguments caused by equivalence. - 3 May 1999: "invisible" tweaks to omit compiler warnings in - abort_.c, ef1asc_.c, s_rnge.c, s_stop.c. - - 7 Sept. 1999: [cz]_div.c: arrange for compilation under - -DIEEE_COMPLEX_DIVIDE to make these routines - avoid calling sig_die when the denominator - vanishes; instead, they return pairs of NaNs - or Infinities, depending whether the numerator - also vanishes or not. VERSION not changed. - 15 Nov. 1999: s_rnge.c: add casts for the case of - sizeof(ftnint) == sizeof(int) < sizeof(long). - 10 March 2000: z_log.c: improve accuracy of Real(log(z)) for, e.g., - z near (+-1,eps) with |eps| small. For the old - evaluation, compile with -DPre20000310 . - 20 April 2000: s_cat.c: tweak argument types to accord with - calls by f2c when ftnint and ftnlen are of - different sizes (different numbers of bits). - 4 July 2000: adjustments to permit compilation by C++ compilers; - VERSION string remains unchanged. - 29 Sept. 2000: dtime_.c, etime_.c: use floating-point divide. - dtime_.d, erf_.c, erfc_.c, etime.c: for use with - "f2c -R", compile with -DREAL=float. - 23 June 2001: add uninit.c; [fi]77vers.c: make version strings - visible as extern char _lib[fi]77_version_f2c[]. - 5 July 2001: modify uninit.c for __mc68k__ under Linux. - 16 Nov. 2001: uninit.c: Linux Power PC logic supplied by Alan Bain. - 18 Jan. 2002: fix glitches in qbit_bits(): wrong return type, - missing ~ on y in return value. - 14 March 2002: z_log.c: add code to cope with buggy compilers - (e.g., some versions of gcc under -O2 or -O3) - that do floating-point comparisons against values - computed into extended-precision registers on some - systems (such as Intel IA32 systems). Compile with - -DNO_DOUBLE_EXTENDED to omit the new logic. - 4 Oct. 2002: uninit.c: on IRIX systems, omit use of shell variables. -*/ diff --git a/ext/f2c_libs/fio.h b/ext/f2c_libs/fio.h deleted file mode 100644 index e7c18bffc..000000000 --- a/ext/f2c_libs/fio.h +++ /dev/null @@ -1,153 +0,0 @@ -#ifndef SYSDEP_H_INCLUDED -#include "sysdep1.h" -#endif -#include "stdio.h" -#include "errno.h" -#ifndef NULL -/* ANSI C */ -#include "stddef.h" -#endif - -#ifndef SEEK_SET -#define SEEK_SET 0 -#define SEEK_CUR 1 -#define SEEK_END 2 -#endif - -#ifndef FOPEN -#define FOPEN fopen -#endif - -#ifndef FREOPEN -#define FREOPEN freopen -#endif - -#ifndef FSEEK -#define FSEEK fseek -#endif - -#ifndef FSTAT -#define FSTAT fstat -#endif - -#ifndef FTELL -#define FTELL ftell -#endif - -#ifndef OFF_T -#define OFF_T long -#endif - -#ifndef STAT_ST -#define STAT_ST stat -#endif - -#ifndef STAT -#define STAT stat -#endif - -#ifdef MSDOS -#ifndef NON_UNIX_STDIO -#define NON_UNIX_STDIO -#endif -#endif - -#ifdef UIOLEN_int -typedef int uiolen; -#else -typedef long uiolen; -#endif - -/*units*/ -typedef struct -{ FILE *ufd; /*0=unconnected*/ - char *ufnm; -#ifndef MSDOS - long uinode; - int udev; -#endif - int url; /*0=sequential*/ - flag useek; /*true=can backspace, use dir, ...*/ - flag ufmt; - flag urw; /* (1 for can read) | (2 for can write) */ - flag ublnk; - flag uend; - flag uwrt; /*last io was write*/ - flag uscrtch; -} unit; - -extern flag f__init; -extern cilist *f__elist; /*active external io list*/ -extern flag f__reading,f__external,f__sequential,f__formatted; -#undef Void -#ifdef KR_headers -#define Void /*void*/ -extern int (*f__getn)(); /* for formatted input */ -extern void (*f__putn)(); /* for formatted output */ -extern void x_putc(); -extern long f__inode(); -extern VOID sig_die(); -extern int (*f__donewrec)(), t_putc(), x_wSL(); -extern int c_sfe(), err__fl(), xrd_SL(), f__putbuf(); -#else -#define Void void -#ifdef __cplusplus -extern "C" { -#endif -extern int (*f__getn)(void); /* for formatted input */ -extern void (*f__putn)(int); /* for formatted output */ -extern void x_putc(int); -extern long f__inode(char*,int*); -extern void sig_die(char*,int); -extern void f__fatal(int,char*); -extern int t_runc(alist*); -extern int f__nowreading(unit*), f__nowwriting(unit*); -extern int fk_open(int,int,ftnint); -extern int en_fio(void); -extern void f_init(void); -extern int (*f__donewrec)(void), t_putc(int), x_wSL(void); -extern void b_char(char*,char*,ftnlen), g_char(char*,ftnlen,char*); -extern int c_sfe(cilist*), z_rnew(void); -#ifndef _WIN32 -extern int isatty(int); -#endif -#ifdef _MSC_VER -#define ISATTY _isatty -#define FILENO _fileno -#define ACCESS _access -#else -#define ISATTY isatty -#define FILENO fileno -#define ACCESS access -#endif -extern int err__fl(int,int,char*); -extern int xrd_SL(void); -extern int f__putbuf(int); -#ifdef __cplusplus - } -#endif -#endif -extern int (*f__doend)(Void); -extern FILE *f__cf; /*current file*/ -extern unit *f__curunit; /*current unit*/ -extern unit f__units[]; -#define err(f,m,s) {if(f) errno= m; else f__fatal(m,s); return(m);} -#define errfl(f,m,s) return err__fl((int)f,m,s) - -/*Table sizes*/ -#define MXUNIT 100 - -extern int f__recpos; /*position in current record*/ -extern OFF_T f__cursor; /* offset to move to */ -extern OFF_T f__hiwater; /* so TL doesn't confuse us */ - -#define WRITE 1 -#define READ 2 -#define SEQ 3 -#define DIR 4 -#define FMT 5 -#define UNF 6 -#define EXT 7 -#define INT 8 - -#define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ) diff --git a/ext/f2c_libs/fmt.c b/ext/f2c_libs/fmt.c deleted file mode 100644 index 80bcd0a76..000000000 --- a/ext/f2c_libs/fmt.c +++ /dev/null @@ -1,525 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#include "fmt.h" -#ifdef __cplusplus -extern "C" { -#endif -#define skip(s) while(*s==' ') s++ -#ifdef interdata -#define SYLMX 300 -#endif -#ifdef pdp11 -#define SYLMX 300 -#endif -#ifdef vax -#define SYLMX 300 -#endif -#ifndef SYLMX -#define SYLMX 300 -#endif -#define GLITCH '\2' - /* special quote character for stu */ -extern flag f__cblank,f__cplus; /*blanks in I and compulsory plus*/ -static struct syl f__syl[SYLMX]; -int f__parenlvl,f__pc,f__revloc; - - static -#ifdef KR_headers -char *ap_end(s) char *s; -#else -char *ap_end(char *s) -#endif -{ char quote; - quote= *s++; - for(;*s;s++) - { if(*s!=quote) continue; - if(*++s!=quote) return(s); - } - if(f__elist->cierr) { - errno = 100; - return(NULL); - } - f__fatal(100, "bad string"); - /*NOTREACHED*/ return 0; -} - static int -#ifdef KR_headers -op_gen(a,b,c,d) -#else -op_gen(int a, int b, int c, int d) -#endif -{ struct syl *p= &f__syl[f__pc]; - if(f__pc>=SYLMX) - { fprintf(stderr,"format too complicated:\n"); - sig_die(f__fmtbuf, 1); - } - p->op=a; - p->p1=b; - p->p2.i[0]=c; - p->p2.i[1]=d; - return(f__pc++); -} -#ifdef KR_headers -static char *f_list(); -static char *gt_num(s,n,n1) char *s; int *n, n1; -#else -static char *f_list(char*); -static char *gt_num(char *s, int *n, int n1) -#endif -{ int m=0,f__cnt=0; - char c; - for(c= *s;;c = *s) - { if(c==' ') - { s++; - continue; - } - if(c>'9' || c<'0') break; - m=10*m+c-'0'; - f__cnt++; - s++; - } - if(f__cnt==0) { - if (!n1) - s = 0; - *n=n1; - } - else *n=m; - return(s); -} - - static -#ifdef KR_headers -char *f_s(s,curloc) char *s; -#else -char *f_s(char *s, int curloc) -#endif -{ - skip(s); - if(*s++!='(') - { - return(NULL); - } - if(f__parenlvl++ ==1) f__revloc=curloc; - if(op_gen(RET1,curloc,0,0)<0 || - (s=f_list(s))==NULL) - { - return(NULL); - } - skip(s); - return(s); -} - - static int -#ifdef KR_headers -ne_d(s,p) char *s,**p; -#else -ne_d(char *s, char **p) -#endif -{ int n,x,sign=0; - struct syl *sp; - switch(*s) - { - default: - return(0); - case ':': (void) op_gen(COLON,0,0,0); break; - case '$': - (void) op_gen(NONL, 0, 0, 0); break; - case 'B': - case 'b': - if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0); - else (void) op_gen(BN,0,0,0); - break; - case 'S': - case 's': - if(*(s+1)=='s' || *(s+1) == 'S') - { x=SS; - s++; - } - else if(*(s+1)=='p' || *(s+1) == 'P') - { x=SP; - s++; - } - else x=S; - (void) op_gen(x,0,0,0); - break; - case '/': (void) op_gen(SLASH,0,0,0); break; - case '-': sign=1; - case '+': s++; /*OUTRAGEOUS CODING TRICK*/ - case '0': case '1': case '2': case '3': case '4': - case '5': case '6': case '7': case '8': case '9': - if (!(s=gt_num(s,&n,0))) { - bad: *p = 0; - return 1; - } - switch(*s) - { - default: - return(0); - case 'P': - case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break; - case 'X': - case 'x': (void) op_gen(X,n,0,0); break; - case 'H': - case 'h': - sp = &f__syl[op_gen(H,n,0,0)]; - sp->p2.s = s + 1; - s+=n; - break; - } - break; - case GLITCH: - case '"': - case '\'': - sp = &f__syl[op_gen(APOS,0,0,0)]; - sp->p2.s = s; - if((*p = ap_end(s)) == NULL) - return(0); - return(1); - case 'T': - case 't': - if(*(s+1)=='l' || *(s+1) == 'L') - { x=TL; - s++; - } - else if(*(s+1)=='r'|| *(s+1) == 'R') - { x=TR; - s++; - } - else x=T; - if (!(s=gt_num(s+1,&n,0))) - goto bad; - s--; - (void) op_gen(x,n,0,0); - break; - case 'X': - case 'x': (void) op_gen(X,1,0,0); break; - case 'P': - case 'p': (void) op_gen(P,1,0,0); break; - } - s++; - *p=s; - return(1); -} - - static int -#ifdef KR_headers -e_d(s,p) char *s,**p; -#else -e_d(char *s, char **p) -#endif -{ int i,im,n,w,d,e,found=0,x=0; - char *sv=s; - s=gt_num(s,&n,1); - (void) op_gen(STACK,n,0,0); - switch(*s++) - { - default: break; - case 'E': - case 'e': x=1; - case 'G': - case 'g': - found=1; - if (!(s=gt_num(s,&w,0))) { - bad: - *p = 0; - return 1; - } - if(w==0) break; - if(*s=='.') { - if (!(s=gt_num(s+1,&d,0))) - goto bad; - } - else d=0; - if(*s!='E' && *s != 'e') - (void) op_gen(x==1?E:G,w,d,0); /* default is Ew.dE2 */ - else { - if (!(s=gt_num(s+1,&e,0))) - goto bad; - (void) op_gen(x==1?EE:GE,w,d,e); - } - break; - case 'O': - case 'o': - i = O; - im = OM; - goto finish_I; - case 'Z': - case 'z': - i = Z; - im = ZM; - goto finish_I; - case 'L': - case 'l': - found=1; - if (!(s=gt_num(s,&w,0))) - goto bad; - if(w==0) break; - (void) op_gen(L,w,0,0); - break; - case 'A': - case 'a': - found=1; - skip(s); - if(*s>='0' && *s<='9') - { s=gt_num(s,&w,1); - if(w==0) break; - (void) op_gen(AW,w,0,0); - break; - } - (void) op_gen(A,0,0,0); - break; - case 'F': - case 'f': - if (!(s=gt_num(s,&w,0))) - goto bad; - found=1; - if(w==0) break; - if(*s=='.') { - if (!(s=gt_num(s+1,&d,0))) - goto bad; - } - else d=0; - (void) op_gen(F,w,d,0); - break; - case 'D': - case 'd': - found=1; - if (!(s=gt_num(s,&w,0))) - goto bad; - if(w==0) break; - if(*s=='.') { - if (!(s=gt_num(s+1,&d,0))) - goto bad; - } - else d=0; - (void) op_gen(D,w,d,0); - break; - case 'I': - case 'i': - i = I; - im = IM; - finish_I: - if (!(s=gt_num(s,&w,0))) - goto bad; - found=1; - if(w==0) break; - if(*s!='.') - { (void) op_gen(i,w,0,0); - break; - } - if (!(s=gt_num(s+1,&d,0))) - goto bad; - (void) op_gen(im,w,d,0); - break; - } - if(found==0) - { f__pc--; /*unSTACK*/ - *p=sv; - return(0); - } - *p=s; - return(1); -} - static -#ifdef KR_headers -char *i_tem(s) char *s; -#else -char *i_tem(char *s) -#endif -{ char *t; - int n,curloc; - if(*s==')') return(s); - if(ne_d(s,&t)) return(t); - if(e_d(s,&t)) return(t); - s=gt_num(s,&n,1); - if((curloc=op_gen(STACK,n,0,0))<0) return(NULL); - return(f_s(s,curloc)); -} - - static -#ifdef KR_headers -char *f_list(s) char *s; -#else -char *f_list(char *s) -#endif -{ - for(;*s!=0;) - { skip(s); - if((s=i_tem(s))==NULL) return(NULL); - skip(s); - if(*s==',') s++; - else if(*s==')') - { if(--f__parenlvl==0) - { - (void) op_gen(REVERT,f__revloc,0,0); - return(++s); - } - (void) op_gen(GOTO,0,0,0); - return(++s); - } - } - return(NULL); -} - - int -#ifdef KR_headers -pars_f(s) char *s; -#else -pars_f(char *s) -#endif -{ - f__parenlvl=f__revloc=f__pc=0; - if(f_s(s,0) == NULL) - { - return(-1); - } - return(0); -} -#define STKSZ 10 -int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp; -flag f__workdone, f__nonl; - - static int -#ifdef KR_headers -type_f(n) -#else -type_f(int n) -#endif -{ - switch(n) - { - default: - return(n); - case RET1: - return(RET1); - case REVERT: return(REVERT); - case GOTO: return(GOTO); - case STACK: return(STACK); - case X: - case SLASH: - case APOS: case H: - case T: case TL: case TR: - return(NED); - case F: - case I: - case IM: - case A: case AW: - case O: case OM: - case L: - case E: case EE: case D: - case G: case GE: - case Z: case ZM: - return(ED); - } -} -#ifdef KR_headers -integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr; -#else -integer do_fio(ftnint *number, char *ptr, ftnlen len) -#endif -{ struct syl *p; - int n,i; - for(i=0;i<*number;i++,ptr+=len) - { -loop: switch(type_f((p= &f__syl[f__pc])->op)) - { - default: - fprintf(stderr,"unknown code in do_fio: %d\n%s\n", - p->op,f__fmtbuf); - err(f__elist->cierr,100,"do_fio"); - case NED: - if((*f__doned)(p)) - { f__pc++; - goto loop; - } - f__pc++; - continue; - case ED: - if(f__cnt[f__cp]<=0) - { f__cp--; - f__pc++; - goto loop; - } - if(ptr==NULL) - return((*f__doend)()); - f__cnt[f__cp]--; - f__workdone=1; - if((n=(*f__doed)(p,ptr,len))>0) - errfl(f__elist->cierr,errno,"fmt"); - if(n<0) - err(f__elist->ciend,(EOF),"fmt"); - continue; - case STACK: - f__cnt[++f__cp]=p->p1; - f__pc++; - goto loop; - case RET1: - f__ret[++f__rp]=p->p1; - f__pc++; - goto loop; - case GOTO: - if(--f__cnt[f__cp]<=0) - { f__cp--; - f__rp--; - f__pc++; - goto loop; - } - f__pc=1+f__ret[f__rp--]; - goto loop; - case REVERT: - f__rp=f__cp=0; - f__pc = p->p1; - if(ptr==NULL) - return((*f__doend)()); - if(!f__workdone) return(0); - if((n=(*f__dorevert)()) != 0) return(n); - goto loop; - case COLON: - if(ptr==NULL) - return((*f__doend)()); - f__pc++; - goto loop; - case NONL: - f__nonl = 1; - f__pc++; - goto loop; - case S: - case SS: - f__cplus=0; - f__pc++; - goto loop; - case SP: - f__cplus = 1; - f__pc++; - goto loop; - case P: f__scale=p->p1; - f__pc++; - goto loop; - case BN: - f__cblank=0; - f__pc++; - goto loop; - case BZ: - f__cblank=1; - f__pc++; - goto loop; - } - } - return(0); -} - - int -en_fio(Void) -{ ftnint one=1; - return(do_fio(&one,(char *)NULL,(ftnint)0)); -} - - VOID -fmt_bg(Void) -{ - f__workdone=f__cp=f__rp=f__pc=f__cursor=0; - f__cnt[0]=f__ret[0]=0; -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/fmt.h b/ext/f2c_libs/fmt.h deleted file mode 100644 index a2fdc6517..000000000 --- a/ext/f2c_libs/fmt.h +++ /dev/null @@ -1,104 +0,0 @@ -struct syl -{ int op; - int p1; - union { int i[2]; char *s;} p2; - }; -#define RET1 1 -#define REVERT 2 -#define GOTO 3 -#define X 4 -#define SLASH 5 -#define STACK 6 -#define I 7 -#define ED 8 -#define NED 9 -#define IM 10 -#define APOS 11 -#define H 12 -#define TL 13 -#define TR 14 -#define T 15 -#define COLON 16 -#define S 17 -#define SP 18 -#define SS 19 -#define P 20 -#define BN 21 -#define BZ 22 -#define F 23 -#define E 24 -#define EE 25 -#define D 26 -#define G 27 -#define GE 28 -#define L 29 -#define A 30 -#define AW 31 -#define O 32 -#define NONL 33 -#define OM 34 -#define Z 35 -#define ZM 36 -extern int f__pc,f__parenlvl,f__revloc; -typedef union -{ real pf; - doublereal pd; -} ufloat; -typedef union -{ short is; -#ifndef KR_headers - signed -#endif - char ic; - integer il; -#ifdef Allow_TYQUAD - longint ili; -#endif -} Uint; -#ifdef KR_headers -extern int (*f__doed)(),(*f__doned)(); -extern int (*f__dorevert)(); -extern int rd_ed(),rd_ned(); -extern int w_ed(),w_ned(); -extern int signbit_f2c(); -#else -#ifdef __cplusplus -extern "C" { -#define Cextern extern "C" -#else -#define Cextern extern -#endif -extern int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*); -extern int (*f__dorevert)(void); -extern void fmt_bg(void); -extern int pars_f(char*); -extern int rd_ed(struct syl*, char*, ftnlen),rd_ned(struct syl*); -extern int signbit_f2c(double*); -extern int w_ed(struct syl*, char*, ftnlen),w_ned(struct syl*); -extern int wrt_E(ufloat*, int, int, int, ftnlen); -extern int wrt_F(ufloat*, int, int, ftnlen); -extern int wrt_L(Uint*, int, ftnlen); -#ifdef __cplusplus - } -#endif -#endif -extern flag f__cblank,f__cplus,f__workdone, f__nonl; -extern char *f__fmtbuf; -extern int f__scale; -#define GET(x) if((x=(*f__getn)())<0) return(x) -#define VAL(x) (x!='\n'?x:' ') -#define PUT(x) (*f__putn)(x) - -#undef TYQUAD -#ifndef Allow_TYQUAD -#undef longint -#define longint long -#else -#define TYQUAD 14 -#endif - -#ifdef KR_headers -extern char *f__icvt(); -#else -Cextern char *f__icvt(longint, int*, int*, int); -#endif diff --git a/ext/f2c_libs/fmtlib.c b/ext/f2c_libs/fmtlib.c deleted file mode 100644 index acbfbc37f..000000000 --- a/ext/f2c_libs/fmtlib.c +++ /dev/null @@ -1,51 +0,0 @@ -/* @(#)fmtlib.c 1.2 */ -#define MAXINTLENGTH 23 - -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif -#ifndef Allow_TYQUAD -#undef longint -#define longint long -#undef ulongint -#define ulongint unsigned long -#endif - -#ifdef KR_headers -char *f__icvt(value,ndigit,sign, base) longint value; int *ndigit,*sign; - register int base; -#else -char *f__icvt(longint value, int *ndigit, int *sign, int base) -#endif -{ - static char buf[MAXINTLENGTH+1]; - register int i; - ulongint uvalue; - - if(value > 0) { - uvalue = value; - *sign = 0; - } - else if (value < 0) { - uvalue = -value; - *sign = 1; - } - else { - *sign = 0; - *ndigit = 1; - buf[MAXINTLENGTH-1] = '0'; - return &buf[MAXINTLENGTH-1]; - } - i = MAXINTLENGTH; - do { - buf[--i] = (char) ((uvalue%base) + '0'); - uvalue /= base; - } - while(uvalue > 0); - *ndigit = MAXINTLENGTH - i; - return &buf[i]; - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/fp.h b/ext/f2c_libs/fp.h deleted file mode 100644 index 40743d79f..000000000 --- a/ext/f2c_libs/fp.h +++ /dev/null @@ -1,28 +0,0 @@ -#define FMAX 40 -#define EXPMAXDIGS 8 -#define EXPMAX 99999999 -/* FMAX = max number of nonzero digits passed to atof() */ -/* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */ - -#ifdef V10 /* Research Tenth-Edition Unix */ -#include "local.h" -#endif - -/* MAXFRACDIGS and MAXINTDIGS are for wrt_F -- bounds (not necessarily - tight) on the maximum number of digits to the right and left of - * the decimal point. - */ - -#ifdef VAX -#define MAXFRACDIGS 56 -#define MAXINTDIGS 38 -#else -#ifdef CRAY -#define MAXFRACDIGS 9880 -#define MAXINTDIGS 9864 -#else -/* values that suffice for IEEE double */ -#define MAXFRACDIGS 344 -#define MAXINTDIGS 308 -#endif -#endif diff --git a/ext/f2c_libs/ftell_.c b/ext/f2c_libs/ftell_.c deleted file mode 100644 index be9f28710..000000000 --- a/ext/f2c_libs/ftell_.c +++ /dev/null @@ -1,52 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#ifdef __cplusplus -extern "C" { -#endif - - static FILE * -#ifdef KR_headers -unit_chk(Unit, who) integer Unit; char *who; -#else -unit_chk(integer Unit, char *who) -#endif -{ - if (Unit >= MXUNIT || Unit < 0) - f__fatal(101, who); - return f__units[Unit].ufd; - } - - integer -#ifdef KR_headers -ftell_(Unit) integer *Unit; -#else -ftell_(integer *Unit) -#endif -{ - FILE *f; - return (f = unit_chk(*Unit, "ftell")) ? ftell(f) : -1L; - } - - int -#ifdef KR_headers -fseek_(Unit, offset, whence) integer *Unit, *offset, *whence; -#else -fseek_(integer *Unit, integer *offset, integer *whence) -#endif -{ - FILE *f; - int w = (int)*whence; -#ifdef SEEK_SET - static int wohin[3] = { SEEK_SET, SEEK_CUR, SEEK_END }; -#endif - if (w < 0 || w > 2) - w = 0; -#ifdef SEEK_SET - w = wohin[w]; -#endif - return !(f = unit_chk(*Unit, "fseek")) - || fseek(f, *offset, w) ? 1 : 0; - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/getenv_.c b/ext/f2c_libs/getenv_.c deleted file mode 100644 index 4d912c524..000000000 --- a/ext/f2c_libs/getenv_.c +++ /dev/null @@ -1,64 +0,0 @@ -#include "f2c.h" -#undef abs -#ifdef KR_headers -extern char *F77_aloc(), *getenv(); -#else -#undef min -#undef max -#include -#include -#ifdef __cplusplus -extern "C" { -#endif -extern char *F77_aloc(ftnlen, char*); -#endif - -/* - * getenv - f77 subroutine to return environment variables - * - * called by: - * call getenv (ENV_NAME, char_var) - * where: - * ENV_NAME is the name of an environment variable - * char_var is a character variable which will receive - * the current value of ENV_NAME, or all blanks - * if ENV_NAME is not defined - */ - -#ifdef KR_headers - VOID -getenv_(fname, value, flen, vlen) char *value, *fname; ftnlen vlen, flen; -#else - void -getenv_(char *fname, char *value, ftnlen flen, ftnlen vlen) -#endif -{ - char buf[256], *ep, *fp; - integer i; - - if (flen <= 0) - goto add_blanks; - for(i = 0; i < sizeof(buf); i++) { - if (i == flen || (buf[i] = fname[i]) == ' ') { - buf[i] = 0; - ep = getenv(buf); - goto have_ep; - } - } - while(i < flen && fname[i] != ' ') - i++; - strncpy(fp = F77_aloc(i+1, "getenv_"), fname, (int)i); - fp[i] = 0; - ep = getenv(fp); - free(fp); - have_ep: - if (ep) - while(*ep && vlen-- > 0) - *value++ = *ep++; - add_blanks: - while(vlen-- > 0) - *value++ = ' '; - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/h_abs.c b/ext/f2c_libs/h_abs.c deleted file mode 100644 index db6906869..000000000 --- a/ext/f2c_libs/h_abs.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -shortint h_abs(x) shortint *x; -#else -shortint h_abs(shortint *x) -#endif -{ -if(*x >= 0) - return(*x); -return(- *x); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/h_dim.c b/ext/f2c_libs/h_dim.c deleted file mode 100644 index 443427a9b..000000000 --- a/ext/f2c_libs/h_dim.c +++ /dev/null @@ -1,16 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -shortint h_dim(a,b) shortint *a, *b; -#else -shortint h_dim(shortint *a, shortint *b) -#endif -{ -return( *a > *b ? *a - *b : 0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/h_dnnt.c b/ext/f2c_libs/h_dnnt.c deleted file mode 100644 index 1ec641c5a..000000000 --- a/ext/f2c_libs/h_dnnt.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double floor(); -shortint h_dnnt(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -shortint h_dnnt(doublereal *x) -#endif -{ -return (shortint)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x)); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/h_indx.c b/ext/f2c_libs/h_indx.c deleted file mode 100644 index 018f2f438..000000000 --- a/ext/f2c_libs/h_indx.c +++ /dev/null @@ -1,32 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -shortint h_indx(a, b, la, lb) char *a, *b; ftnlen la, lb; -#else -shortint h_indx(char *a, char *b, ftnlen la, ftnlen lb) -#endif -{ -ftnlen i, n; -char *s, *t, *bend; - -n = la - lb + 1; -bend = b + lb; - -for(i = 0 ; i < n ; ++i) - { - s = a + i; - t = b; - while(t < bend) - if(*s++ != *t++) - goto no; - return((shortint)i+1); - no: ; - } -return(0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/h_len.c b/ext/f2c_libs/h_len.c deleted file mode 100644 index 8b0aea99d..000000000 --- a/ext/f2c_libs/h_len.c +++ /dev/null @@ -1,16 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -shortint h_len(s, n) char *s; ftnlen n; -#else -shortint h_len(char *s, ftnlen n) -#endif -{ -return(n); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/h_mod.c b/ext/f2c_libs/h_mod.c deleted file mode 100644 index 611ef0aa8..000000000 --- a/ext/f2c_libs/h_mod.c +++ /dev/null @@ -1,16 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -shortint h_mod(a,b) short *a, *b; -#else -shortint h_mod(short *a, short *b) -#endif -{ -return( *a % *b); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/h_nint.c b/ext/f2c_libs/h_nint.c deleted file mode 100644 index 9e2282f2a..000000000 --- a/ext/f2c_libs/h_nint.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double floor(); -shortint h_nint(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -shortint h_nint(real *x) -#endif -{ -return (shortint)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/h_sign.c b/ext/f2c_libs/h_sign.c deleted file mode 100644 index 4e214380c..000000000 --- a/ext/f2c_libs/h_sign.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -shortint h_sign(a,b) shortint *a, *b; -#else -shortint h_sign(shortint *a, shortint *b) -#endif -{ -shortint x; -x = (*a >= 0 ? *a : - *a); -return( *b >= 0 ? x : -x); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/hl_ge.c b/ext/f2c_libs/hl_ge.c deleted file mode 100644 index 8c72f03d4..000000000 --- a/ext/f2c_libs/hl_ge.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -extern integer s_cmp(); -shortlogical hl_ge(a,b,la,lb) char *a, *b; ftnlen la, lb; -#else -extern integer s_cmp(char *, char *, ftnlen, ftnlen); -shortlogical hl_ge(char *a, char *b, ftnlen la, ftnlen lb) -#endif -{ -return(s_cmp(a,b,la,lb) >= 0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/hl_gt.c b/ext/f2c_libs/hl_gt.c deleted file mode 100644 index a448522db..000000000 --- a/ext/f2c_libs/hl_gt.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -extern integer s_cmp(); -shortlogical hl_gt(a,b,la,lb) char *a, *b; ftnlen la, lb; -#else -extern integer s_cmp(char *, char *, ftnlen, ftnlen); -shortlogical hl_gt(char *a, char *b, ftnlen la, ftnlen lb) -#endif -{ -return(s_cmp(a,b,la,lb) > 0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/hl_le.c b/ext/f2c_libs/hl_le.c deleted file mode 100644 index 31cbc431a..000000000 --- a/ext/f2c_libs/hl_le.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -extern integer s_cmp(); -shortlogical hl_le(a,b,la,lb) char *a, *b; ftnlen la, lb; -#else -extern integer s_cmp(char *, char *, ftnlen, ftnlen); -shortlogical hl_le(char *a, char *b, ftnlen la, ftnlen lb) -#endif -{ -return(s_cmp(a,b,la,lb) <= 0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/hl_lt.c b/ext/f2c_libs/hl_lt.c deleted file mode 100644 index 7ad3c714b..000000000 --- a/ext/f2c_libs/hl_lt.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -extern integer s_cmp(); -shortlogical hl_lt(a,b,la,lb) char *a, *b; ftnlen la, lb; -#else -extern integer s_cmp(char *, char *, ftnlen, ftnlen); -shortlogical hl_lt(char *a, char *b, ftnlen la, ftnlen lb) -#endif -{ -return(s_cmp(a,b,la,lb) < 0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/i77vers.c b/ext/f2c_libs/i77vers.c deleted file mode 100644 index 60cc24eec..000000000 --- a/ext/f2c_libs/i77vers.c +++ /dev/null @@ -1,343 +0,0 @@ - char -_libi77_version_f2c[] = "\n@(#) LIBI77 VERSION (f2c) pjw,dmg-mods 20030321\n"; - -/* -2.01 $ format added -2.02 Coding bug in open.c repaired -2.03 fixed bugs in lread.c (read * with negative f-format) and lio.c - and lio.h (e-format conforming to spec) -2.04 changed open.c and err.c (fopen and freopen respectively) to - update to new c-library (append mode) -2.05 added namelist capability -2.06 allow internal list and namelist I/O -*/ - -/* -close.c: - allow upper-case STATUS= values -endfile.c - create fort.nnn if unit nnn not open; - else if (file length == 0) use creat() rather than copy; - use local copy() rather than forking /bin/cp; - rewind, fseek to clear buffer (for no reading past EOF) -err.c - use neither setbuf nor setvbuf; make stderr buffered -fio.h - #define _bufend -inquire.c - upper case responses; - omit byfile test from SEQUENTIAL= - answer "YES" to DIRECT= for unopened file (open to debate) -lio.c - flush stderr, stdout at end of each stmt - space before character strings in list output only at line start -lio.h - adjust LEW, LED consistent with old libI77 -lread.c - use atof() - allow "nnn*," when reading complex constants -open.c - try opening for writing when open for read fails, with - special uwrt value (2) delaying creat() to first write; - set curunit so error messages don't drop core; - no file name ==> fort.nnn except for STATUS='SCRATCH' -rdfmt.c - use atof(); trust EOF == end-of-file (so don't read past - end-of-file after endfile stmt) -sfe.c - flush stderr, stdout at end of each stmt -wrtfmt.c: - use upper case - put wrt_E and wrt_F into wref.c, use sprintf() - rather than ecvt() and fcvt() [more accurate on VAX] -*/ - -/* 16 Oct. 1988: uwrt = 3 after write, rewind, so close won't zap the file. */ - -/* 10 July 1989: change _bufend to buf_end in fio.h, wsfe.c, wrtfmt.c */ - -/* 28 Nov. 1989: corrections for IEEE and Cray arithmetic */ -/* 29 Nov. 1989: change various int return types to long for f2c */ -/* 30 Nov. 1989: various types from f2c.h */ -/* 6 Dec. 1989: types corrected various places */ -/* 19 Dec. 1989: make iostat= work right for internal I/O */ -/* 8 Jan. 1990: add rsne, wsne -- routines for handling NAMELIST */ -/* 28 Jan. 1990: have NAMELIST read treat $ as &, general white - space as blank */ -/* 27 Mar. 1990: change an = to == in rd_L(rdfmt.c) so formatted reads - of logical values reject letters other than fFtT; - have nowwriting reset cf */ -/* 14 Aug. 1990: adjust lread.c to treat tabs as spaces in list input */ -/* 17 Aug. 1990: adjust open.c to recognize blank='Z...' as well as - blank='z...' when reopening an open file */ -/* 30 Aug. 1990: prevent embedded blanks in list output of complex values; - omit exponent field in list output of values of - magnitude between 10 and 1e8; prevent writing stdin - and reading stdout or stderr; don't close stdin, stdout, - or stderr when reopening units 5, 6, 0. */ -/* 18 Sep. 1990: add component udev to unit and consider old == new file - iff uinode and udev values agree; use stat rather than - access to check existence of file (when STATUS='OLD')*/ -/* 2 Oct. 1990: adjust rewind.c so two successive rewinds after a write - don't clobber the file. */ -/* 9 Oct. 1990: add #include "fcntl.h" to endfile.c, err.c, open.c; - adjust g_char in util.c for segmented memories. */ -/* 17 Oct. 1990: replace abort() and _cleanup() with calls on - sig_die(...,1) (defined in main.c). */ -/* 5 Nov. 1990: changes to open.c: complain if new= is specified and the - file already exists; allow file= to be omitted in open stmts - and allow status='replace' (Fortran 90 extensions). */ -/* 11 Dec. 1990: adjustments for POSIX. */ -/* 15 Jan. 1991: tweak i_ungetc in rsli.c to allow reading from - strings in read-only memory. */ -/* 25 Apr. 1991: adjust namelist stuff to work with f2c -i2 */ -/* 26 Apr. 1991: fix some bugs with NAMELIST read of multi-dim. arrays */ -/* 16 May 1991: increase LEFBL in lio.h to bypass NeXT bug */ -/* 17 Oct. 1991: change type of length field in sequential unformatted - records from int to long (for systems where sizeof(int) - can vary, depending on the compiler or compiler options). */ -/* 14 Nov. 1991: change uint to Uint in fmt.h, rdfmt.c, wrtfmt.c. */ -/* 25 Nov. 1991: change uint to Uint in lwrite.c; change sizeof(int) to - sizeof(uioint) in fseeks in sue.c (missed on 17 Oct.). */ -/* 1 Dec. 1991: uio.c: add test for read failure (seq. unformatted reads); - adjust an error return from EOF to off end of record */ -/* 12 Dec. 1991: rsli.c: fix bug with internal list input that caused - the last character of each record to be ignored. - iio.c: adjust error message in internal formatted - input from "end-of-file" to "off end of record" if - the format specifies more characters than the - record contains. */ -/* 17 Jan. 1992: lread.c, rsne.c: in list and namelist input, - treat "r* ," and "r*," alike (where r is a - positive integer constant), and fix a bug in - handling null values following items with repeat - counts (e.g., 2*1,,3); for namelist reading - of a numeric array, allow a new name-value subsequence - to terminate the current one (as though the current - one ended with the right number of null values). - lio.h, lwrite.c: omit insignificant zeros in - list and namelist output. To get the old - behavior, compile with -DOld_list_output . */ -/* 18 Jan. 1992: make list output consistent with F format by - printing .1 rather than 0.1 (introduced yesterday). */ -/* 3 Feb. 1992: rsne.c: fix namelist read bug that caused the - character following a comma to be ignored. */ -/* 19 May 1992: adjust iio.c, ilnw.c, rdfmt.c and rsli.c to make err= - work with internal list and formatted I/O. */ -/* 18 July 1992: adjust rsne.c to allow namelist input to stop at - an & (e.g. &end). */ -/* 23 July 1992: switch to ANSI prototypes unless KR_headers is #defined ; - recognize Z format (assuming 8-bit bytes). */ -/* 14 Aug. 1992: tweak wrt_E in wref.c to avoid -NaN */ -/* 23 Oct. 1992: Supply missing l_eof = 0 assignment to s_rsne() in rsne.c - (so end-of-file on other files won't confuse namelist - reads of external files). Prepend f__ to external - names that are only of internal interest to lib[FI]77. */ -/* 1 Feb. 1993: backspace.c: fix bug that bit when last char of 2nd - buffer == '\n'. - endfile.c: guard against tiny L_tmpnam; close and reopen - files in t_runc(). - lio.h: lengthen LINTW (buffer size in lwrite.c). - err.c, open.c: more prepending of f__ (to [rw]_mode). */ -/* 5 Feb. 1993: tweaks to NAMELIST: rsne.c: ? prints the namelist being - sought; namelists of the wrong name are skipped (after - an error message; xwsne.c: namelist writes have a - newline before each new variable. - open.c: ACCESS='APPEND' positions sequential files - at EOF (nonstandard extension -- that doesn't require - changing data structures). */ -/* 9 Feb. 1993: Change some #ifdef MSDOS lines to #ifdef NON_UNIX_STDIO. - err.c: under NON_UNIX_STDIO, avoid close(creat(name,0666)) - when the unit has another file descriptor for name. */ -/* 4 March 1993: err.c, open.c: take declaration of fdopen from rawio.h; - open.c: always give f__w_mode[] 4 elements for use - in t_runc (in endfile.c -- for change of 1 Feb. 1993). */ -/* 6 March 1993: uio.c: adjust off-end-of-record test for sequential - unformatted reads to respond to err= rather than end=. */ -/* 12 March 1993: various tweaks for C++ */ -/* 6 April 1993: adjust error returns for formatted inputs to flush - the current input line when err=label is specified. - To restore the old behavior (input left mid-line), - either adjust the #definition of errfl in fio.h or - omit the invocation of f__doend in err__fl (in err.c). */ -/* 23 June 1993: iio.c: fix bug in format reversions for internal writes. */ -/* 5 Aug. 1993: lread.c: fix bug in handling repetition counts for - logical data (during list or namelist input). - Change struct f__syl to struct syl (for buggy compilers). */ -/* 7 Aug. 1993: lread.c: fix bug in namelist reading of incomplete - logical arrays. */ -/* 9 Aug. 1993: lread.c: fix bug in namelist reading of an incomplete - array of numeric data followed by another namelist - item whose name starts with 'd', 'D', 'e', or 'E'. */ -/* 8 Sept. 1993: open.c: protect #include "sys/..." with - #ifndef NON_UNIX_STDIO; Version date not changed. */ -/* 10 Nov. 1993: backspace.c: add nonsense for #ifdef MSDOS */ -/* 8 Dec. 1993: iio.c: adjust internal formatted reads to treat - short records as though padded with blanks - (rather than causing an "off end of record" error). */ -/* 22 Feb. 1994: lread.c: check that realloc did not return NULL. */ -/* 6 June 1994: Under NON_UNIX_STDIO, use binary mode for direct - formatted files (avoiding any confusion regarding \n). */ -/* 5 July 1994: Fix bug (introduced 6 June 1994?) in reopening files - under NON_UNIX_STDIO. */ -/* 6 July 1994: wref.c: protect with #ifdef GOOD_SPRINTF_EXPONENT an - optimization that requires exponents to have 2 digits - when 2 digits suffice. - lwrite.c wsfe.c (list and formatted external output): - omit ' ' carriage-control when compiled with - -DOMIT_BLANK_CC . Off-by-one bug fixed in character - count for list output of character strings. - Omit '.' in list-directed printing of Nan, Infinity. */ -/* 12 July 1994: wrtfmt.c: under G11.4, write 0. as " .0000 " rather - than " .0000E+00". */ -/* 3 Aug. 1994: lwrite.c: do not insert a newline when appending an - oversize item to an empty line. */ -/* 12 Aug. 1994: rsli.c rsne.c: fix glitch (reset nml_read) that kept - ERR= (in list- or format-directed input) from working - after a NAMELIST READ. */ -/* 7 Sept. 1994: typesize.c: adjust to allow types LOGICAL*1, LOGICAL*2, - INTEGER*1, and (under -DAllow_TYQUAD) INTEGER*8 - in NAMELISTs. */ -/* 6 Oct. 1994: util.c: omit f__mvgbt, as it is never used. */ -/* 2 Nov. 1994: add #ifdef ALWAYS_FLUSH logic. */ -/* 26 Jan. 1995: wref.c: fix glitch in printing the exponent of 0 when - GOOD_SPRINTF_EXPONENT is not #defined. */ -/* 24 Feb. 1995: iio.c: z_getc: insert (unsigned char *) to allow - internal reading of characters with high-bit set - (on machines that sign-extend characters). */ -/* 14 March 1995:lread.c and rsfe.c: adjust s_rsle and s_rsfe to - check for end-of-file (to prevent infinite loops - with empty read statements). */ -/* 26 May 1995: iio.c: z_wnew: fix bug in handling T format items - in internal writes whose last item is written to - an earlier position than some previous item. */ -/* 29 Aug. 1995: backspace.c: adjust MSDOS logic. */ -/* 6 Sept. 1995: Adjust namelist input to treat a subscripted name - whose subscripts do not involve colons similarly - to the name without a subscript: accept several - values, stored in successive elements starting at - the indicated subscript. Adjust namelist output - to quote character strings (avoiding confusion with - arrays of character strings). Adjust f_init calls - for people who don't use libF77's main(); now open and - namelist read statements invoke f_init if needed. */ -/* 7 Sept. 1995: Fix some bugs with -DAllow_TYQUAD (for integer*8). - Add -DNo_Namelist_Comments lines to rsne.c. */ -/* 5 Oct. 1995: wrtfmt.c: fix bug with t editing (f__cursor was not - always zeroed in mv_cur). */ -/* 11 Oct. 1995: move defs of f__hiwater, f__svic, f__icptr from wrtfmt.c - to err.c */ -/* 15 Mar. 1996: lread.c, rsfe.c: honor END= in READ stmt with empty iolist */ - -/* 13 May 1996: add ftell_.c and fseek_.c */ -/* 9 June 1996: Adjust rsli.c and lread.c so internal list input with - too few items in the input string will honor end= . */ -/* 12 Sept. 1995:fmtlib.c: fix glitch in printing the most negative integer. */ -/* 25 Sept. 1995:fmt.h: for formatted writes of negative integer*1 values, - make ic signed on ANSI systems. If formatted writes of - integer*1 values trouble you when using a K&R C compiler, - switch to an ANSI compiler or use a compiler flag that - makes characters signed. */ -/* 9 Dec. 1996: d[fu]e.c, err.c: complain about non-positive rec= - in direct read and write statements. - ftell_.c: change param "unit" to "Unit" for -DKR_headers. */ -/* 26 Feb. 1997: ftell_.c: on systems that define SEEK_SET, etc., use - SEEK_SET, SEEK_CUR, SEEK_END for *whence = 0, 1, 2. */ -/* 7 Apr. 1997: fmt.c: adjust to complain at missing numbers in formats - (but still treat missing ".nnn" as ".0"). */ -/* 11 Apr. 1997: err.c: attempt to make stderr line buffered rather - than fully buffered. (Buffering is needed for format - items T and TR.) */ -/* 27 May 1997: ftell_.c: fix typo (that caused the third argument to be - treated as 2 on some systems). */ -/* 5 Aug. 1997: lread.c: adjust to accord with a change to the Fortran 8X - draft (in 1990 or 1991) that rescinded permission to elide - quote marks in namelist input of character data; compile - with -DF8X_NML_ELIDE_QUOTES to get the old behavior. - wrtfmt.o: wrt_G: tweak to print the right number of 0's - for zero under G format. */ -/* 16 Aug. 1997: iio.c: fix bug in internal writes to an array of character - strings that sometimes caused one more array element than - required by the format to be blank-filled. Example: - format(1x). */ -/* 16 Sept. 1997:fmt.[ch] rdfmt.c wrtfmt.c: tweak struct syl for machines - with 64-bit pointers and 32-bit ints that did not 64-bit - align struct syl (e.g., Linux on the DEC Alpha). */ -/* 19 Jan. 1998: backspace.c: for b->ufmt==0, change sizeof(int) to - sizeof(uiolen). On machines where this would make a - difference, it is best for portability to compile libI77 with - -DUIOLEN_int (which will render the change invisible). */ -/* 4 March 1998: open.c: fix glitch in comparing file names under - -DNON_UNIX_STDIO */ -/* 17 March 1998: endfile.c, open.c: acquire temporary files from tmpfile(), - unless compiled with -DNON_ANSI_STDIO, which uses mktemp(). - New buffering scheme independent of NON_UNIX_STDIO for - handling T format items. Now -DNON_UNIX_STDIO is no - longer be necessary for Linux, and libf2c no longer - causes stderr to be buffered -- the former setbuf or - setvbuf call for stderr was to make T format items work. - open.c: use the Posix access() function to check existence - or nonexistence of files, except under -DNON_POSIX_STDIO, - where trial fopen calls are used. */ -/* 5 April 1998: wsfe.c: make $ format item work: this was lost in the - changes of 17 March 1998. */ -/* 28 May 1998: backspace.c dfe.c due.c iio.c lread.c rsfe.c sue.c wsfe.c: - set f__curunit sooner so various error messages will - correctly identify the I/O unit involved. */ -/* 17 June 1998: lread.c: unless compiled with - ALLOW_FLOAT_IN_INTEGER_LIST_INPUT #defined, treat - floating-point numbers (containing either a decimal point - or an exponent field) as errors when they appear as list - input for integer data. */ -/* 7 Sept. 1998: move e_wdfe from sfe.c to dfe.c, where it was originally. - Why did it ever move to sfe.c? */ -/* 2 May 1999: open.c: set f__external (to get "external" versus "internal" - right in the error message if we cannot open the file). - err.c: cast a pointer difference to (int) for %d. - rdfmt.c: omit fixed-length buffer that could be overwritten - by formats Inn or Lnn with nn > 83. */ -/* 3 May 1999: open.c: insert two casts for machines with 64-bit longs. */ -/* 18 June 1999: backspace.c: allow for b->ufd changing in t_runc */ -/* 27 June 1999: rsne.c: fix bug in namelist input: a misplaced increment */ -/* could cause wrong array elements to be assigned; e.g., */ -/* "&input k(5)=10*1 &end" assigned k(5) and k(15..23) */ -/* 15 Nov. 1999: endfile.c: set state to writing (b->uwrt = 1) when an */ -/* endfile statement requires copying the file. */ -/* (Otherwise an immediately following rewind statement */ -/* could make the file appear empty.) Also, supply a */ -/* missing (long) cast in the sprintf call. */ -/* sfe.c: add #ifdef ALWAYS_FLUSH logic, for formatted I/O: */ -/* Compiling libf2c with -DALWAYS_FLUSH should prevent losing */ -/* any data in buffers should the program fault. It also */ -/* makes the program run more slowly. */ -/* 20 April 2000: rsne.c, xwsne.c: tweaks that only matter if ftnint and */ -/* ftnlen are of different fundamental types (different numbers */ -/* of bits). Since these files will not compile when this */ -/* change matters, the above VERSION string remains unchanged. */ -/* 4 July 2000: adjustments to permit compilation by C++ compilers; */ -/* VERSION string remains unchanged. */ -/* 5 Dec. 2000: lread.c: under namelist input, when reading a logical array, */ -/* treat Tstuff= and Fstuff= as new assignments rather than as */ -/* logical constants. */ -/* 22 Feb. 2001: endfile.c: adjust to use truncate() unless compiled with */ -/* -DNO_TRUNCATE (or with -DMSDOS). */ -/* 1 March 2001: endfile.c: switch to ftruncate (absent -DNO_TRUNCATE), */ -/* thus permitting truncation of scratch files on true Unix */ -/* systems, where scratch files have no name. Add an fflush() */ -/* (surprisingly) needed on some Linux systems. */ -/* 11 Oct. 2001: backspac.c dfe.c due.c endfile.c err.c fio.h fmt.c fmt.h */ -/* inquire.c open.c rdfmt.c sue.c util.c: change fseek and */ -/* ftell to FSEEK and FTELL (#defined to be fseek and ftell, */ -/* respectively, in fio.h unless otherwise #defined), and use */ -/* type OFF_T (#defined to be long unless otherwise #defined) */ -/* to permit handling files over 2GB long where possible, */ -/* with suitable -D options, provided for some systems in new */ -/* header file sysdep1.h (copied from sysdep1.h0 by default). */ -/* 15 Nov. 2001: endfile.c: add FSEEK after FTRUNCATE. */ -/* 28 Nov. 2001: fmt.h lwrite.c wref.c and (new) signbit.c: on IEEE systems, */ -/* print -0 as -0 when compiled with -DSIGNED_ZEROS. See */ -/* comments in makefile or (better) libf2c/makefile.* . */ -/* 6 Sept. 2002: rsne.c: fix bug with multiple repeat counts in reading */ -/* namelists, e.g., &nl a(2) = 3*1.0, 2*2.0, 3*3.0 / */ -/* 21 March 2003: err.c: before writing to a file after reading from it, */ -/* f_seek(file, 0, SEEK_CUR) to make writing legal in ANSI C. */ diff --git a/ext/f2c_libs/i_abs.c b/ext/f2c_libs/i_abs.c deleted file mode 100644 index 2b92c4aa7..000000000 --- a/ext/f2c_libs/i_abs.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -integer i_abs(x) integer *x; -#else -integer i_abs(integer *x) -#endif -{ -if(*x >= 0) - return(*x); -return(- *x); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/i_dim.c b/ext/f2c_libs/i_dim.c deleted file mode 100644 index 60ed4d8c5..000000000 --- a/ext/f2c_libs/i_dim.c +++ /dev/null @@ -1,16 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -integer i_dim(a,b) integer *a, *b; -#else -integer i_dim(integer *a, integer *b) -#endif -{ -return( *a > *b ? *a - *b : 0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/i_dnnt.c b/ext/f2c_libs/i_dnnt.c deleted file mode 100644 index 3abc2dc4a..000000000 --- a/ext/f2c_libs/i_dnnt.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double floor(); -integer i_dnnt(x) doublereal *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -integer i_dnnt(doublereal *x) -#endif -{ -return (integer)(*x >= 0. ? floor(*x + .5) : -floor(.5 - *x)); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/i_indx.c b/ext/f2c_libs/i_indx.c deleted file mode 100644 index 19256393e..000000000 --- a/ext/f2c_libs/i_indx.c +++ /dev/null @@ -1,32 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -integer i_indx(a, b, la, lb) char *a, *b; ftnlen la, lb; -#else -integer i_indx(char *a, char *b, ftnlen la, ftnlen lb) -#endif -{ -ftnlen i, n; -char *s, *t, *bend; - -n = la - lb + 1; -bend = b + lb; - -for(i = 0 ; i < n ; ++i) - { - s = a + i; - t = b; - while(t < bend) - if(*s++ != *t++) - goto no; - return(i+1); - no: ; - } -return(0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/i_len.c b/ext/f2c_libs/i_len.c deleted file mode 100644 index 0f7b188d6..000000000 --- a/ext/f2c_libs/i_len.c +++ /dev/null @@ -1,16 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -integer i_len(s, n) char *s; ftnlen n; -#else -integer i_len(char *s, ftnlen n) -#endif -{ -return(n); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/i_mod.c b/ext/f2c_libs/i_mod.c deleted file mode 100644 index 4a9b5609b..000000000 --- a/ext/f2c_libs/i_mod.c +++ /dev/null @@ -1,16 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -integer i_mod(a,b) integer *a, *b; -#else -integer i_mod(integer *a, integer *b) -#endif -{ -return( *a % *b); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/i_nint.c b/ext/f2c_libs/i_nint.c deleted file mode 100644 index fe9fd68a8..000000000 --- a/ext/f2c_libs/i_nint.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double floor(); -integer i_nint(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -integer i_nint(real *x) -#endif -{ -return (integer)(*x >= 0 ? floor(*x + .5) : -floor(.5 - *x)); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/i_sign.c b/ext/f2c_libs/i_sign.c deleted file mode 100644 index 4c20e9494..000000000 --- a/ext/f2c_libs/i_sign.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -integer i_sign(a,b) integer *a, *b; -#else -integer i_sign(integer *a, integer *b) -#endif -{ -integer x; -x = (*a >= 0 ? *a : - *a); -return( *b >= 0 ? x : -x); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/iio.c b/ext/f2c_libs/iio.c deleted file mode 100644 index 6641f6ead..000000000 --- a/ext/f2c_libs/iio.c +++ /dev/null @@ -1,159 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#include "fmt.h" -#ifdef __cplusplus -extern "C" { -#endif -extern char *f__icptr; -char *f__icend; -extern icilist *f__svic; -int f__icnum; - - int -z_getc(Void) -{ - if(f__recpos++ < f__svic->icirlen) { - if(f__icptr >= f__icend) err(f__svic->iciend,(EOF),"endfile"); - return(*(unsigned char *)f__icptr++); - } - return '\n'; -} - - void -#ifdef KR_headers -z_putc(c) -#else -z_putc(int c) -#endif -{ - if (f__icptr < f__icend && f__recpos++ < f__svic->icirlen) - *f__icptr++ = c; -} - - int -z_rnew(Void) -{ - f__icptr = f__svic->iciunit + (++f__icnum)*f__svic->icirlen; - f__recpos = 0; - f__cursor = 0; - f__hiwater = 0; - return 1; -} - - static int -z_endp(Void) -{ - (*f__donewrec)(); - return 0; - } - - int -#ifdef KR_headers -c_si(a) icilist *a; -#else -c_si(icilist *a) -#endif -{ - f__elist = (cilist *)a; - f__fmtbuf=a->icifmt; - f__curunit = 0; - f__sequential=f__formatted=1; - f__external=0; - if(pars_f(f__fmtbuf)<0) - err(a->icierr,100,"startint"); - fmt_bg(); - f__cblank=f__cplus=f__scale=0; - f__svic=a; - f__icnum=f__recpos=0; - f__cursor = 0; - f__hiwater = 0; - f__icptr = a->iciunit; - f__icend = f__icptr + a->icirlen*a->icirnum; - f__cf = 0; - return(0); -} - - int -iw_rev(Void) -{ - if(f__workdone) - z_endp(); - f__hiwater = f__recpos = f__cursor = 0; - return(f__workdone=0); - } - -#ifdef KR_headers -integer s_rsfi(a) icilist *a; -#else -integer s_rsfi(icilist *a) -#endif -{ int n; - if((n=c_si(a))) return(n); - f__reading=1; - f__doed=rd_ed; - f__doned=rd_ned; - f__getn=z_getc; - f__dorevert = z_endp; - f__donewrec = z_rnew; - f__doend = z_endp; - return(0); -} - - int -z_wnew(Void) -{ - if (f__recpos < f__hiwater) { - f__icptr += f__hiwater - f__recpos; - f__recpos = f__hiwater; - } - while(f__recpos++ < f__svic->icirlen) - *f__icptr++ = ' '; - f__recpos = 0; - f__cursor = 0; - f__hiwater = 0; - f__icnum++; - return 1; -} -#ifdef KR_headers -integer s_wsfi(a) icilist *a; -#else -integer s_wsfi(icilist *a) -#endif -{ int n; - if((n=c_si(a))) return(n); - f__reading=0; - f__doed=w_ed; - f__doned=w_ned; - f__putn=z_putc; - f__dorevert = iw_rev; - f__donewrec = z_wnew; - f__doend = z_endp; - return(0); -} -integer e_rsfi(Void) -{ int n = en_fio(); - f__fmtbuf = NULL; - return(n); -} -integer e_wsfi(Void) -{ - int n; - n = en_fio(); - f__fmtbuf = NULL; - if(f__svic->icirnum != 1 - && (f__icnum > f__svic->icirnum - || (f__icnum == f__svic->icirnum && (f__recpos | f__hiwater)))) - err(f__svic->icierr,110,"inwrite"); - if (f__recpos < f__hiwater) - f__recpos = f__hiwater; - if (f__recpos >= f__svic->icirlen) - err(f__svic->icierr,110,"recend"); - if (!f__recpos && f__icnum) - return n; - while(f__recpos++ < f__svic->icirlen) - *f__icptr++ = ' '; - return n; -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/ilnw.c b/ext/f2c_libs/ilnw.c deleted file mode 100644 index e8b3d49cf..000000000 --- a/ext/f2c_libs/ilnw.c +++ /dev/null @@ -1,83 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#include "lio.h" -#ifdef __cplusplus -extern "C" { -#endif -extern char *f__icptr; -extern char *f__icend; -extern icilist *f__svic; -extern int f__icnum; -#ifdef KR_headers -extern void z_putc(); -#else -extern void z_putc(int); -#endif - - static int -z_wSL(Void) -{ - while(f__recpos < f__svic->icirlen) - z_putc(' '); - return z_rnew(); - } - - static void -#ifdef KR_headers -c_liw(a) icilist *a; -#else -c_liw(icilist *a) -#endif -{ - f__reading = 0; - f__external = 0; - f__formatted = 1; - f__putn = z_putc; - L_len = a->icirlen; - f__donewrec = z_wSL; - f__svic = a; - f__icnum = f__recpos = 0; - f__cursor = 0; - f__cf = 0; - f__curunit = 0; - f__icptr = a->iciunit; - f__icend = f__icptr + a->icirlen*a->icirnum; - f__elist = (cilist *)a; - } - - integer -#ifdef KR_headers -s_wsni(a) icilist *a; -#else -s_wsni(icilist *a) -#endif -{ - cilist ca; - - c_liw(a); - ca.cifmt = a->icifmt; - x_wsne(&ca); - z_wSL(); - return 0; - } - - integer -#ifdef KR_headers -s_wsli(a) icilist *a; -#else -s_wsli(icilist *a) -#endif -{ - f__lioproc = l_write; - c_liw(a); - return(0); - } - -integer e_wsli(Void) -{ - z_wSL(); - return(0); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/inquire.c b/ext/f2c_libs/inquire.c deleted file mode 100644 index bbb3cc872..000000000 --- a/ext/f2c_libs/inquire.c +++ /dev/null @@ -1,132 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#include "string.h" -#ifdef NON_UNIX_STDIO -#ifndef MSDOS -#include "unistd.h" /* for access() */ -#endif -#endif -#ifdef KR_headers -integer f_inqu(a) inlist *a; -#else -#ifdef __cplusplus -extern "C" integer f_inqu(inlist*); -#endif -#ifdef MSDOS -#undef abs -#undef min -#undef max -#include "io.h" -#endif -integer f_inqu(inlist *a) -#endif -{ flag byfile; - int i; -#ifndef NON_UNIX_STDIO - int n; -#endif - unit *p; - char buf[256]; - long x; - if(a->infile!=NULL) - { byfile=1; - g_char(a->infile,a->infilen,buf); -#ifdef NON_UNIX_STDIO - x = ACCESS(buf,0) ? -1 : 0; - for(i=0,p=NULL;iinunitinunit>=0) - { - p= &f__units[a->inunit]; - } - else - { - p=NULL; - } - } - if(a->inex!=NULL) { - if((byfile && x != -1) || (!byfile && p!=NULL)) { - *a->inex=1; - } else { - *a->inex=0; - } - } - if(a->inopen!=NULL) { - if(byfile) *a->inopen=(p!=NULL); - else *a->inopen=(p!=NULL && p->ufd!=NULL); - } - if(a->innum!=NULL) *a->innum= (ftnint) (p-f__units); - if(a->innamed!=NULL) { - if(byfile || (p!=NULL && p->ufnm!=NULL)) - *a->innamed=1; - else *a->innamed=0; - } - if(a->inname!=NULL) { - if(byfile) - b_char(buf,a->inname,a->innamlen); - else if(p!=NULL && p->ufnm!=NULL) - b_char(p->ufnm,a->inname,a->innamlen); - } - if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL) { - if(p->url) - b_char("DIRECT",a->inacc,a->inacclen); - else b_char("SEQUENTIAL",a->inacc,a->inacclen); - } - if(a->inseq!=NULL) { - if(p!=NULL && p->url) - b_char("NO",a->inseq,a->inseqlen); - else b_char("YES",a->inseq,a->inseqlen); - } - if(a->indir!=NULL) { - if(p==NULL || p->url) - b_char("YES",a->indir,a->indirlen); - else b_char("NO",a->indir,a->indirlen); - } - if(a->infmt!=NULL) { - if(p!=NULL && p->ufmt==0) - b_char("UNFORMATTED",a->infmt,a->infmtlen); - else b_char("FORMATTED",a->infmt,a->infmtlen); - } - if(a->inform!=NULL) { - if(p!=NULL && p->ufmt==0) - b_char("NO",a->inform,a->informlen); - else b_char("YES",a->inform,a->informlen); - } - if(a->inunf) { - if(p!=NULL && p->ufmt==0) - b_char("YES",a->inunf,a->inunflen); - else { - if (p!=NULL) b_char("NO",a->inunf,a->inunflen); - else b_char("UNKNOWN",a->inunf,a->inunflen); - } - } - if(a->inrecl!=NULL && p!=NULL) - *a->inrecl=p->url; - if(a->innrec!=NULL && p!=NULL && p->url>0) - *a->innrec=(ftnint)(FTELL(p->ufd)/p->url+1); - if(a->inblank && p!=NULL && p->ufmt) { - if(p->ublnk) - b_char("ZERO",a->inblank,a->inblanklen); - else b_char("NULL",a->inblank,a->inblanklen); - } - return(0); -} diff --git a/ext/f2c_libs/l_ge.c b/ext/f2c_libs/l_ge.c deleted file mode 100644 index a84f0ee4a..000000000 --- a/ext/f2c_libs/l_ge.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -extern integer s_cmp(); -logical l_ge(a,b,la,lb) char *a, *b; ftnlen la, lb; -#else -extern integer s_cmp(char *, char *, ftnlen, ftnlen); -logical l_ge(char *a, char *b, ftnlen la, ftnlen lb) -#endif -{ -return(s_cmp(a,b,la,lb) >= 0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/l_gt.c b/ext/f2c_libs/l_gt.c deleted file mode 100644 index ae6950d13..000000000 --- a/ext/f2c_libs/l_gt.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -extern integer s_cmp(); -logical l_gt(a,b,la,lb) char *a, *b; ftnlen la, lb; -#else -extern integer s_cmp(char *, char *, ftnlen, ftnlen); -logical l_gt(char *a, char *b, ftnlen la, ftnlen lb) -#endif -{ -return(s_cmp(a,b,la,lb) > 0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/l_le.c b/ext/f2c_libs/l_le.c deleted file mode 100644 index 625b49a9e..000000000 --- a/ext/f2c_libs/l_le.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -extern integer s_cmp(); -logical l_le(a,b,la,lb) char *a, *b; ftnlen la, lb; -#else -extern integer s_cmp(char *, char *, ftnlen, ftnlen); -logical l_le(char *a, char *b, ftnlen la, ftnlen lb) -#endif -{ -return(s_cmp(a,b,la,lb) <= 0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/l_lt.c b/ext/f2c_libs/l_lt.c deleted file mode 100644 index ab21b362d..000000000 --- a/ext/f2c_libs/l_lt.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -extern integer s_cmp(); -logical l_lt(a,b,la,lb) char *a, *b; ftnlen la, lb; -#else -extern integer s_cmp(char *, char *, ftnlen, ftnlen); -logical l_lt(char *a, char *b, ftnlen la, ftnlen lb) -#endif -{ -return(s_cmp(a,b,la,lb) < 0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/lbitbits.c b/ext/f2c_libs/lbitbits.c deleted file mode 100644 index 2f44abf9d..000000000 --- a/ext/f2c_libs/lbitbits.c +++ /dev/null @@ -1,68 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifndef LONGBITS -#define LONGBITS 32 -#endif - - integer -#ifdef KR_headers -lbit_bits(a, b, len) integer a, b, len; -#else -lbit_bits(integer a, integer b, integer len) -#endif -{ - /* Assume 2's complement arithmetic */ - - unsigned long x, y; - - x = (unsigned long) a; - y = (unsigned long)-1L; - x >>= b; - y <<= len; - return (integer)(x & ~y); - } - - integer -#ifdef KR_headers -lbit_cshift(a, b, len) integer a, b, len; -#else -lbit_cshift(integer a, integer b, integer len) -#endif -{ - unsigned long x, y, z; - - x = (unsigned long)a; - if (len <= 0) { - if (len == 0) - return 0; - goto full_len; - } - if (len >= LONGBITS) { - full_len: - if (b >= 0) { - b %= LONGBITS; - return (integer)(x << b | x >> (LONGBITS -b) ); - } - b = -b; - b %= LONGBITS; - return (integer)(x << (LONGBITS - b) | x >> b); - } - y = z = (unsigned long)-1; - y <<= len; - z &= ~y; - y &= x; - x &= z; - if (b >= 0) { - b %= len; - return (integer)((y) | (z & (x << b | x >> (len - b)))); - } - b = -b; - b %= len; - return (integer)((y) | (z & (x >> b | x << (len - b)))); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/lbitshft.c b/ext/f2c_libs/lbitshft.c deleted file mode 100644 index fbee94f14..000000000 --- a/ext/f2c_libs/lbitshft.c +++ /dev/null @@ -1,17 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - - integer -#ifdef KR_headers -lbit_shift(a, b) integer a; integer b; -#else -lbit_shift(integer a, integer b) -#endif -{ - return b >= 0 ? a << b : (integer)((uinteger)a >> -b); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/lio.h b/ext/f2c_libs/lio.h deleted file mode 100644 index 012317206..000000000 --- a/ext/f2c_libs/lio.h +++ /dev/null @@ -1,74 +0,0 @@ -/* copy of ftypes from the compiler */ -/* variable types - * numeric assumptions: - * int < reals < complexes - * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX - */ - -/* 0-10 retain their old (pre LOGICAL*1, etc.) */ -/* values to allow mixing old and new objects. */ - -#define TYUNKNOWN 0 -#define TYADDR 1 -#define TYSHORT 2 -#define TYLONG 3 -#define TYREAL 4 -#define TYDREAL 5 -#define TYCOMPLEX 6 -#define TYDCOMPLEX 7 -#define TYLOGICAL 8 -#define TYCHAR 9 -#define TYSUBR 10 -#define TYINT1 11 -#define TYLOGICAL1 12 -#define TYLOGICAL2 13 -#ifdef Allow_TYQUAD -#undef TYQUAD -#define TYQUAD 14 -#endif - -#define LINTW 24 -#define LINE 80 -#define LLOGW 2 -#ifdef Old_list_output -#define LLOW 1.0 -#define LHIGH 1.e9 -#define LEFMT " %# .8E" -#define LFFMT " %# .9g" -#else -#define LGFMT "%.9G" -#endif -/* LEFBL 20 should suffice; 24 overcomes a NeXT bug. */ -#define LEFBL 24 - -typedef union -{ - char flchar; - short flshort; - ftnint flint; -#ifdef Allow_TYQUAD - longint fllongint; -#endif - real flreal; - doublereal fldouble; -} flex; -extern int f__scale; -#ifdef KR_headers -extern int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); -extern int l_read(), l_write(); -#else -#ifdef __cplusplus -extern "C" { -#endif -extern int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint); -extern int l_write(ftnint*, char*, ftnlen, ftnint); -extern void x_wsne(cilist*); -extern int c_le(cilist*), (*l_getc)(void), (*l_ungetc)(int,FILE*); -extern int l_read(ftnint*,char*,ftnlen,ftnint); -extern integer e_rsle(void), e_wsle(void), s_wsne(cilist*); -extern int z_rnew(void); -#ifdef __cplusplus - } -#endif -#endif -extern ftnint L_len; diff --git a/ext/f2c_libs/lread.c b/ext/f2c_libs/lread.c deleted file mode 100644 index 0e317dd69..000000000 --- a/ext/f2c_libs/lread.c +++ /dev/null @@ -1,809 +0,0 @@ -#include "f2c.h" -#include "fio.h" - -/* Compile with -DF8X_NML_ELIDE_QUOTES to permit eliding quotation */ -/* marks in namelist input a la the Fortran 8X Draft published in */ -/* the May 1989 issue of Fortran Forum. */ - - -extern char *f__fmtbuf; - -#ifdef Allow_TYQUAD -static longint f__llx; -#endif - -#ifdef KR_headers -extern double atof(); -extern char *malloc(), *realloc(); -int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)(); -#else -#undef abs -#undef min -#undef max -#include "stdlib.h" -#endif - -#include "fmt.h" -#include "lio.h" -#include "ctype.h" -#include "fp.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifndef KR_headers -int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void), - (*l_ungetc)(int,FILE*); -#endif - -int l_eof; - -#define isblnk(x) (f__ltab[x+1]&B) -#define issep(x) (f__ltab[x+1]&SX) -#define isapos(x) (f__ltab[x+1]&AX) -#define isexp(x) (f__ltab[x+1]&EX) -#define issign(x) (f__ltab[x+1]&SG) -#define iswhit(x) (f__ltab[x+1]&WH) -#define SX 1 -#define B 2 -#define AX 4 -#define EX 8 -#define SG 16 -#define WH 32 -char f__ltab[128+1] = { /* offset one for EOF */ - 0, - 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, - AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0, - 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 -}; - -#ifdef ungetc - static int -#ifdef KR_headers -un_getc(x,f__cf) int x; FILE *f__cf; -#else -un_getc(int x, FILE *f__cf) -#endif -{ return ungetc(x,f__cf); } -#else -#define un_getc ungetc -#ifdef KR_headers - extern int ungetc(); -#else -#ifndef _WIN32 -extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ -#endif -#endif -#endif - - int -t_getc(Void) -{ int ch; - if(f__curunit->uend) return(EOF); - if((ch=getc(f__cf))!=EOF) return(ch); - if(feof(f__cf)) - f__curunit->uend = l_eof = 1; - return(EOF); -} -integer e_rsle(Void) -{ - int ch; - if(f__curunit->uend) return(0); - while((ch=t_getc())!='\n') - if (ch == EOF) { - if(feof(f__cf)) - f__curunit->uend = l_eof = 1; - return EOF; - } - return(0); -} - -flag f__lquit; -int f__lcount,f__ltype,nml_read; -char *f__lchar; -double f__lx,f__ly; -#define ERR(x) if((n=(x))) return(n) -#define GETC(x) (x=(*l_getc)()) -#define Ungetc(x,y) (*l_ungetc)(x,y) - - static int -#ifdef KR_headers -l_R(poststar, reqint) int poststar, reqint; -#else -l_R(int poststar, int reqint) -#endif -{ - char s[FMAX+EXPMAXDIGS+4]; - register int ch; - register char *sp, *spe, *sp1; - long e, exp; - int havenum, havestar, se; - - if (!poststar) { - if (f__lcount > 0) - return(0); - f__lcount = 1; - } -#ifdef Allow_TYQUAD - f__llx = 0; -#endif - f__ltype = 0; - exp = 0; - havestar = 0; -retry: - sp1 = sp = s; - spe = sp + FMAX; - havenum = 0; - - switch(GETC(ch)) { - case '-': *sp++ = ch; sp1++; spe++; - case '+': - GETC(ch); - } - while(ch == '0') { - ++havenum; - GETC(ch); - } - while(isdigit(ch)) { - if (sp < spe) *sp++ = ch; - else ++exp; - GETC(ch); - } - if (ch == '*' && !poststar) { - if (sp == sp1 || exp || *s == '-') { - errfl(f__elist->cierr,112,"bad repetition count"); - } - poststar = havestar = 1; - *sp = 0; - f__lcount = atoi(s); - goto retry; - } - if (ch == '.') { -#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT - if (reqint) - errfl(f__elist->cierr,115,"invalid integer"); -#endif - GETC(ch); - if (sp == sp1) - while(ch == '0') { - ++havenum; - --exp; - GETC(ch); - } - while(isdigit(ch)) { - if (sp < spe) - { *sp++ = ch; --exp; } - GETC(ch); - } - } - havenum += (int) (sp - sp1); - se = 0; - if (issign(ch)) - goto signonly; - if (havenum && isexp(ch)) { -#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT - if (reqint) - errfl(f__elist->cierr,115,"invalid integer"); -#endif - GETC(ch); - if (issign(ch)) { -signonly: - if (ch == '-') se = 1; - GETC(ch); - } - if (!isdigit(ch)) { -bad: - errfl(f__elist->cierr,112,"exponent field"); - } - - e = ch - '0'; - while(isdigit(GETC(ch))) { - e = 10*e + ch - '0'; - if (e > EXPMAX) - goto bad; - } - if (se) - exp -= e; - else - exp += e; - } - (void) Ungetc(ch, f__cf); - if (sp > sp1) { - ++havenum; - while(*--sp == '0') - ++exp; - if (exp) - sprintf(sp+1, "e%ld", exp); - else - sp[1] = 0; - f__lx = atof(s); -#ifdef Allow_TYQUAD - if (reqint&2 && (se = sp - sp1 + exp) > 14 && se < 20) { - /* Assuming 64-bit longint and 32-bit long. */ - if (exp < 0) - sp += exp; - if (sp1 <= sp) { - f__llx = *sp1 - '0'; - while(++sp1 <= sp) - f__llx = 10*f__llx + (*sp1 - '0'); - } - while(--exp >= 0) - f__llx *= 10; - if (*s == '-') - f__llx = -f__llx; - } -#endif - } - else - f__lx = 0.; - if (havenum) - f__ltype = TYLONG; - else - switch(ch) { - case ',': - case '/': - break; - default: - if (havestar && ( ch == ' ' - ||ch == '\t' - ||ch == '\n')) - break; - if (nml_read > 1) { - f__lquit = 2; - return 0; - } - errfl(f__elist->cierr,112,"invalid number"); - } - return 0; - } - - static int -#ifdef KR_headers -rd_count(ch) register int ch; -#else -rd_count(register int ch) -#endif -{ - if (ch < '0' || ch > '9') - return 1; - f__lcount = ch - '0'; - while(GETC(ch) >= '0' && ch <= '9') - f__lcount = 10*f__lcount + ch - '0'; - Ungetc(ch,f__cf); - return f__lcount <= 0; - } - - static int -l_C(Void) -{ int ch, nml_save; - double lz; - if(f__lcount>0) return(0); - f__ltype=0; - GETC(ch); - if(ch!='(') - { - if (nml_read > 1 && (ch < '0' || ch > '9')) { - Ungetc(ch,f__cf); - f__lquit = 2; - return 0; - } - if (rd_count(ch)) { - if(!f__cf || !feof(f__cf)) - errfl(f__elist->cierr,112,"complex format"); - else - err(f__elist->cierr,(EOF),"lread"); - } - if(GETC(ch)!='*') - { - if(!f__cf || !feof(f__cf)) - errfl(f__elist->cierr,112,"no star"); - else - err(f__elist->cierr,(EOF),"lread"); - } - if(GETC(ch)!='(') - { Ungetc(ch,f__cf); - return(0); - } - } - else - f__lcount = 1; - while(iswhit(GETC(ch))); - Ungetc(ch,f__cf); - nml_save = nml_read; - nml_read = 0; - if ((ch = l_R(1,0))) - return ch; - if (!f__ltype) - errfl(f__elist->cierr,112,"no real part"); - lz = f__lx; - while(iswhit(GETC(ch))); - if(ch!=',') - { (void) Ungetc(ch,f__cf); - errfl(f__elist->cierr,112,"no comma"); - } - while(iswhit(GETC(ch))); - (void) Ungetc(ch,f__cf); - if ((ch = l_R(1,0))) - return ch; - if (!f__ltype) - errfl(f__elist->cierr,112,"no imaginary part"); - while(iswhit(GETC(ch))); - if(ch!=')') errfl(f__elist->cierr,112,"no )"); - f__ly = f__lx; - f__lx = lz; -#ifdef Allow_TYQUAD - f__llx = 0; -#endif - nml_read = nml_save; - return(0); -} - - static char nmLbuf[256], *nmL_next; - static int (*nmL_getc_save)(Void); -#ifdef KR_headers - static int (*nmL_ungetc_save)(/* int, FILE* */); -#else - static int (*nmL_ungetc_save)(int, FILE*); -#endif - - static int -nmL_getc(Void) -{ - int rv; - if ((rv = *nmL_next++)) - return rv; - l_getc = nmL_getc_save; - l_ungetc = nmL_ungetc_save; - return (*l_getc)(); - } - - static int -#ifdef KR_headers -nmL_ungetc(x, f) int x; FILE *f; -#else -nmL_ungetc(int x, FILE *f) -#endif -{ - f = f; /* banish non-use warning */ - return *--nmL_next = x; - } - - static int -#ifdef KR_headers -Lfinish(ch, dot, rvp) int ch, dot, *rvp; -#else -Lfinish(int ch, int dot, int *rvp) -#endif -{ - char *s, *se; - static char what[] = "namelist input"; - - s = nmLbuf + 2; - se = nmLbuf + sizeof(nmLbuf) - 1; - *s++ = ch; - while(!issep(GETC(ch)) && ch!=EOF) { - if (s >= se) { - nmLbuf_ovfl: - return *rvp = err__fl(f__elist->cierr,131,what); - } - *s++ = ch; - if (ch != '=') - continue; - if (dot) - return *rvp = err__fl(f__elist->cierr,112,what); - got_eq: - *s = 0; - nmL_getc_save = l_getc; - l_getc = nmL_getc; - nmL_ungetc_save = l_ungetc; - l_ungetc = nmL_ungetc; - nmLbuf[1] = *(nmL_next = nmLbuf) = ','; - *rvp = f__lcount = 0; - return 1; - } - if (dot) - goto done; - for(;;) { - if (s >= se) - goto nmLbuf_ovfl; - *s++ = ch; - if (!isblnk(ch)) - break; - if (GETC(ch) == EOF) - goto done; - } - if (ch == '=') - goto got_eq; - done: - Ungetc(ch, f__cf); - return 0; - } - - static int -l_L(Void) -{ - int ch, rv, sawdot; - - if(f__lcount>0) - return(0); - f__lcount = 1; - f__ltype=0; - GETC(ch); - if(isdigit(ch)) - { - rd_count(ch); - if(GETC(ch)!='*') { - if(!f__cf || !feof(f__cf)) - errfl(f__elist->cierr,112,"no star"); - else - err(f__elist->cierr,(EOF),"lread"); - } - GETC(ch); - } - sawdot = 0; - if(ch == '.') { - sawdot = 1; - GETC(ch); - } - switch(ch) - { - case 't': - case 'T': - if (nml_read && Lfinish(ch, sawdot, &rv)) - return rv; - f__lx=1; - break; - case 'f': - case 'F': - if (nml_read && Lfinish(ch, sawdot, &rv)) - return rv; - f__lx=0; - break; - default: - if(isblnk(ch) || issep(ch) || ch==EOF) - { (void) Ungetc(ch,f__cf); - return(0); - } - if (nml_read > 1) { - Ungetc(ch,f__cf); - f__lquit = 2; - return 0; - } - errfl(f__elist->cierr,112,"logical"); - } - f__ltype=TYLONG; - while(!issep(GETC(ch)) && ch!=EOF); - Ungetc(ch, f__cf); - return(0); -} - -#define BUFSIZE 128 - - static int -l_CHAR(Void) -{ int ch,size,i; - static char rafail[] = "realloc failure"; - char quote,*p; - if(f__lcount>0) return(0); - f__ltype=0; - if(f__lchar!=NULL) free(f__lchar); - size=BUFSIZE; - p=f__lchar = (char *)malloc((unsigned int)size); - if(f__lchar == NULL) - errfl(f__elist->cierr,113,"no space"); - - GETC(ch); - if(isdigit(ch)) { - /* allow Fortran 8x-style unquoted string... */ - /* either find a repetition count or the string */ - f__lcount = ch - '0'; - *p++ = ch; - for(i = 1;;) { - switch(GETC(ch)) { - case '*': - if (f__lcount == 0) { - f__lcount = 1; -#ifndef F8X_NML_ELIDE_QUOTES - if (nml_read) - goto no_quote; -#endif - goto noquote; - } - p = f__lchar; - goto have_lcount; - case ',': - case ' ': - case '\t': - case '\n': - case '/': - Ungetc(ch,f__cf); - /* no break */ - case EOF: - f__lcount = 1; - f__ltype = TYCHAR; - return *p = 0; - } - if (!isdigit(ch)) { - f__lcount = 1; -#ifndef F8X_NML_ELIDE_QUOTES - if (nml_read) { - no_quote: - errfl(f__elist->cierr,112, - "undelimited character string"); - } -#endif - goto noquote; - } - *p++ = ch; - f__lcount = 10*f__lcount + ch - '0'; - if (++i == size) { - f__lchar = (char *)realloc(f__lchar, - (unsigned int)(size += BUFSIZE)); - if(f__lchar == NULL) - errfl(f__elist->cierr,113,rafail); - p = f__lchar + i; - } - } - } - else (void) Ungetc(ch,f__cf); - have_lcount: - if(GETC(ch)=='\'' || ch=='"') quote=ch; - else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF) { - Ungetc(ch,f__cf); - return 0; - } -#ifndef F8X_NML_ELIDE_QUOTES - else if (nml_read > 1) { - Ungetc(ch,f__cf); - f__lquit = 2; - return 0; - } -#endif - else { - /* Fortran 8x-style unquoted string */ - *p++ = ch; - for(i = 1;;) { - switch(GETC(ch)) { - case ',': - case ' ': - case '\t': - case '\n': - case '/': - Ungetc(ch,f__cf); - /* no break */ - case EOF: - f__ltype = TYCHAR; - return *p = 0; - } - noquote: - *p++ = ch; - if (++i == size) { - f__lchar = (char *)realloc(f__lchar, - (unsigned int)(size += BUFSIZE)); - if(f__lchar == NULL) - errfl(f__elist->cierr,113,rafail); - p = f__lchar + i; - } - } - } - f__ltype=TYCHAR; - for(i=0;;) - { while(GETC(ch)!=quote && ch!='\n' - && ch!=EOF && ++icierr,113,rafail); - p=f__lchar+i-1; - *p++ = ch; - } - else if(ch==EOF) return(EOF); - else if(ch=='\n') - { if(*(p-1) != '\\') continue; - i--; - p--; - if(++iciunit]; - if(a->ciunit>=MXUNIT || a->ciunit<0) - err(a->cierr,101,"stler"); - f__scale=f__recpos=0; - f__elist=a; - if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) - err(a->cierr,102,"lio"); - f__cf=f__curunit->ufd; - if(!f__curunit->ufmt) err(a->cierr,103,"lio") - return(0); -} - - int -#ifdef KR_headers -l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; -#else -l_read(ftnint *number, char *ptr, ftnlen len, ftnint type) -#endif -{ -#define Ptr ((flex *)ptr) - int i,n,ch; - doublereal *yy; - real *xx; - for(i=0;i<*number;i++) - { - if(f__lquit) return(0); - if(l_eof) - err(f__elist->ciend, EOF, "list in") - if(f__lcount == 0) { - f__ltype = 0; - for(;;) { - GETC(ch); - switch(ch) { - case EOF: - err(f__elist->ciend,(EOF),"list in") - case ' ': - case '\t': - case '\n': - continue; - case '/': - f__lquit = 1; - goto loopend; - case ',': - f__lcount = 1; - goto loopend; - default: - (void) Ungetc(ch, f__cf); - goto rddata; - } - } - } - rddata: - switch((int)type) - { - case TYINT1: - case TYSHORT: - case TYLONG: -#ifndef ALLOW_FLOAT_IN_INTEGER_LIST_INPUT - ERR(l_R(0,1)); - break; -#endif - case TYREAL: - case TYDREAL: - ERR(l_R(0,0)); - break; -#ifdef TYQUAD - case TYQUAD: - n = l_R(0,2); - if (n) - return n; - break; -#endif - case TYCOMPLEX: - case TYDCOMPLEX: - ERR(l_C()); - break; - case TYLOGICAL1: - case TYLOGICAL2: - case TYLOGICAL: - ERR(l_L()); - break; - case TYCHAR: - ERR(l_CHAR()); - break; - } - while (GETC(ch) == ' ' || ch == '\t'); - if (ch != ',' || f__lcount > 1) - Ungetc(ch,f__cf); - loopend: - if(f__lquit) return(0); - if(f__cf && ferror(f__cf)) { - clearerr(f__cf); - errfl(f__elist->cierr,errno,"list in"); - } - if(f__ltype==0) goto bump; - switch((int)type) - { - case TYINT1: - case TYLOGICAL1: - Ptr->flchar = (char)f__lx; - break; - case TYLOGICAL2: - case TYSHORT: - Ptr->flshort = (short)f__lx; - break; - case TYLOGICAL: - case TYLONG: - Ptr->flint = (ftnint)f__lx; - break; -#ifdef Allow_TYQUAD - case TYQUAD: - if (!(Ptr->fllongint = f__llx)) - Ptr->fllongint = f__lx; - break; -#endif - case TYREAL: - Ptr->flreal= (real) f__lx; - break; - case TYDREAL: - Ptr->fldouble=f__lx; - break; - case TYCOMPLEX: - xx=(real *)ptr; - *xx++ = (real) f__lx; - *xx = (real) f__ly; - break; - case TYDCOMPLEX: - yy=(doublereal *)ptr; - *yy++ = f__lx; - *yy = f__ly; - break; - case TYCHAR: - b_char(f__lchar,ptr,len); - break; - } - bump: - if(f__lcount>0) f__lcount--; - ptr += len; - if (nml_read) - nml_read++; - } - return(0); -#undef Ptr -} -#ifdef KR_headers -integer s_rsle(a) cilist *a; -#else -integer s_rsle(cilist *a) -#endif -{ - int n; - - f__reading=1; - f__external=1; - f__formatted=1; - if((n=c_le(a))) return(n); - f__lioproc = l_read; - f__lquit = 0; - f__lcount = 0; - l_eof = 0; - if(f__curunit->uwrt && f__nowreading(f__curunit)) - err(a->cierr,errno,"read start"); - if(f__curunit->uend) - err(f__elist->ciend,(EOF),"read start"); - l_getc = t_getc; - l_ungetc = un_getc; - f__doend = xrd_SL; - return(0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/lwrite.c b/ext/f2c_libs/lwrite.c deleted file mode 100644 index 5b5fe249d..000000000 --- a/ext/f2c_libs/lwrite.c +++ /dev/null @@ -1,314 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#include "fmt.h" -#include "lio.h" -#ifdef __cplusplus -extern "C" { -#endif - -ftnint L_len; -int f__Aquote; - - static VOID -donewrec(Void) -{ - if (f__recpos) - (*f__donewrec)(); - } - - static VOID -#ifdef KR_headers -lwrt_I(n) longint n; -#else -lwrt_I(longint n) -#endif -{ - char *p; - int ndigit, sign; - - p = f__icvt(n, &ndigit, &sign, 10); - if(f__recpos + ndigit >= L_len) - donewrec(); - PUT(' '); - if (sign) - PUT('-'); - while(*p) - PUT(*p++); -} - static VOID -#ifdef KR_headers -lwrt_L(n, len) ftnint n; ftnlen len; -#else -lwrt_L(ftnint n, ftnlen len) -#endif -{ - if(f__recpos+LLOGW>=L_len) - donewrec(); - wrt_L((Uint *)&n,LLOGW, len); -} - static VOID -#ifdef KR_headers -lwrt_A(p,len) char *p; ftnlen len; -#else -lwrt_A(char *p, ftnlen len) -#endif -{ - int a; - char *p1, *pe; - - a = 0; - pe = p + len; - if (f__Aquote) { - a = 3; - if (len > 1 && p[len-1] == ' ') { - while(--len > 1 && p[len-1] == ' '); - pe = p + len; - } - p1 = p; - while(p1 < pe) - if (*p1++ == '\'') - a++; - } - if(f__recpos+len+a >= L_len) - donewrec(); - if (a -#ifndef OMIT_BLANK_CC - || !f__recpos -#endif - ) - PUT(' '); - if (a) { - PUT('\''); - while(p < pe) { - if (*p == '\'') - PUT('\''); - PUT(*p++); - } - PUT('\''); - } - else - while(p < pe) - PUT(*p++); -} - - static int -#ifdef KR_headers -l_g(buf, n) char *buf; double n; -#else -l_g(char *buf, double n) -#endif -{ -#ifdef Old_list_output - doublereal absn; - char *fmt; - - absn = n; - if (absn < 0) - absn = -absn; - fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT; -#ifdef USE_STRLEN - sprintf(buf, fmt, n); - return strlen(buf); -#else - return sprintf(buf, fmt, n); -#endif - -#else - register char *b, c, c1; - - b = buf; - *b++ = ' '; - if (n < 0) { - *b++ = '-'; - n = -n; - } - else - *b++ = ' '; - if (n == 0) { -#ifdef SIGNED_ZEROS - if (signbit_f2c(&n)) - *b++ = '-'; -#endif - *b++ = '0'; - *b++ = '.'; - *b = 0; - goto f__ret; - } - sprintf(b, LGFMT, n); - switch(*b) { -#ifndef WANT_LEAD_0 - case '0': - while(b[0] = b[1]) - b++; - break; -#endif - case 'i': - case 'I': - /* Infinity */ - case 'n': - case 'N': - /* NaN */ - while(*++b); - break; - - default: - /* Fortran 77 insists on having a decimal point... */ - for(;; b++) - switch(*b) { - case 0: - *b++ = '.'; - *b = 0; - goto f__ret; - case '.': - while(*++b); - goto f__ret; - case 'E': - for(c1 = '.', c = 'E'; *b = c1; - c1 = c, c = *++b); - goto f__ret; - } - } - f__ret: - return (int) (b - buf); -#endif - } - - static VOID -#ifdef KR_headers -l_put(s) register char *s; -#else -l_put(register char *s) -#endif -{ -#ifdef KR_headers - register void (*pn)() = f__putn; -#else - register void (*pn)(int) = f__putn; -#endif - register int c; - - while(c = *s++) - (*pn)(c); - } - - static VOID -#ifdef KR_headers -lwrt_F(n) double n; -#else -lwrt_F(double n) -#endif -{ - char buf[LEFBL]; - - if(f__recpos + l_g(buf,n) >= L_len) - donewrec(); - l_put(buf); -} - static VOID -#ifdef KR_headers -lwrt_C(a,b) double a,b; -#else -lwrt_C(double a, double b) -#endif -{ - char *ba, *bb, bufa[LEFBL], bufb[LEFBL]; - int al, bl; - - al = l_g(bufa, a); - for(ba = bufa; *ba == ' '; ba++) - --al; - bl = l_g(bufb, b) + 1; /* intentionally high by 1 */ - for(bb = bufb; *bb == ' '; bb++) - --bl; - if(f__recpos + al + bl + 3 >= L_len) - donewrec(); -#ifdef OMIT_BLANK_CC - else -#endif - PUT(' '); - PUT('('); - l_put(ba); - PUT(','); - if (f__recpos + bl >= L_len) { - (*f__donewrec)(); -#ifndef OMIT_BLANK_CC - PUT(' '); -#endif - } - l_put(bb); - PUT(')'); -} - - int -#ifdef KR_headers -l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len; -#else -l_write(ftnint *number, char *ptr, ftnlen len, ftnint type) -#endif -{ -#define Ptr ((flex *)ptr) - int i; - longint x; - double y,z; - real *xx; - doublereal *yy; - for(i=0;i< *number; i++) - { - switch((int)type) - { - default: f__fatal(117,"unknown type in lio"); - case TYINT1: - x = Ptr->flchar; - goto xint; - case TYSHORT: - x=Ptr->flshort; - goto xint; -#ifdef Allow_TYQUAD - case TYQUAD: - x = Ptr->fllongint; - goto xint; -#endif - case TYLONG: - x=Ptr->flint; - xint: lwrt_I(x); - break; - case TYREAL: - y=Ptr->flreal; - goto xfloat; - case TYDREAL: - y=Ptr->fldouble; - xfloat: lwrt_F(y); - break; - case TYCOMPLEX: - xx= &Ptr->flreal; - y = *xx++; - z = *xx; - goto xcomplex; - case TYDCOMPLEX: - yy = &Ptr->fldouble; - y= *yy++; - z = *yy; - xcomplex: - lwrt_C(y,z); - break; - case TYLOGICAL1: - x = Ptr->flchar; - goto xlog; - case TYLOGICAL2: - x = Ptr->flshort; - goto xlog; - case TYLOGICAL: - x = Ptr->flint; - xlog: lwrt_L(Ptr->flint, len); - break; - case TYCHAR: - lwrt_A(ptr,len); - break; - } - ptr += len; - } - return(0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/open.c b/ext/f2c_libs/open.c deleted file mode 100644 index 6b14b50d0..000000000 --- a/ext/f2c_libs/open.c +++ /dev/null @@ -1,299 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#include "string.h" -#ifndef NON_POSIX_STDIO -#ifdef MSDOS -#include "io.h" -#else -#include "unistd.h" /* for access */ -#endif -#endif - -#ifdef KR_headers -extern char *malloc(); -#ifdef NON_ANSI_STDIO -extern char *mktemp(); -#endif -extern integer f_clos(); -#else -#undef abs -#undef min -#undef max -#include "stdlib.h" -#ifdef __cplusplus -extern "C" { -#endif -extern int f__canseek(FILE*); -extern integer f_clos(cllist*); -#endif - -#ifdef NON_ANSI_RW_MODES -char *f__r_mode[2] = {"r", "r"}; -char *f__w_mode[4] = {"w", "w", "r+w", "r+w"}; -#else -char *f__r_mode[2] = {"rb", "r"}; -char *f__w_mode[4] = {"wb", "w", "r+b", "r+"}; -#endif - - static char f__buf0[400], *f__buf = f__buf0; - int f__buflen = (int)sizeof(f__buf0); - - static void -#ifdef KR_headers -f__bufadj(n, c) int n, c; -#else -f__bufadj(int n, int c) -#endif -{ - unsigned int len; - char *nbuf, *s, *t, *te; - - if (f__buf == f__buf0) - f__buflen = 1024; - while(f__buflen <= n) - f__buflen <<= 1; - len = (unsigned int)f__buflen; - if (len != f__buflen || !(nbuf = (char*)malloc(len))) - f__fatal(113, "malloc failure"); - s = nbuf; - t = f__buf; - te = t + c; - while(t < te) - *s++ = *t++; - if (f__buf != f__buf0) - free(f__buf); - f__buf = nbuf; - } - - int -#ifdef KR_headers -f__putbuf(c) int c; -#else -f__putbuf(int c) -#endif -{ - char *s, *se; - int n; - - if (f__hiwater > f__recpos) - f__recpos = f__hiwater; - n = f__recpos + 1; - if (n >= f__buflen) - f__bufadj(n, f__recpos); - s = f__buf; - se = s + f__recpos; - if (c) - *se++ = c; - *se = 0; - for(;;) { - fputs(s, f__cf); - s += strlen(s); - if (s >= se) - break; /* normally happens the first time */ - putc(*s++, f__cf); - } - return 0; - } - - void -#ifdef KR_headers -x_putc(c) -#else -x_putc(int c) -#endif -{ - if (f__recpos >= f__buflen) - f__bufadj(f__recpos, f__buflen); - f__buf[f__recpos++] = c; - } - -#define opnerr(f,m,s) {if(f) errno= m; else opn_err(m,s,a); return(m);} - - static void -#ifdef KR_headers -opn_err(m, s, a) int m; char *s; olist *a; -#else -opn_err(int m, char *s, olist *a) -#endif -{ - if (a->ofnm) { - /* supply file name to error message */ - if (a->ofnmlen >= f__buflen) - f__bufadj((int)a->ofnmlen, 0); - g_char(a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf); - } - f__fatal(m, s); - } - -#ifdef KR_headers -integer f_open(a) olist *a; -#else -integer f_open(olist *a) -#endif -{ unit *b; - integer rv; - char buf[256], *s; - cllist x; - int ufmt; - FILE *tf; -#ifndef NON_UNIX_STDIO - int n; -#endif - f__external = 1; - if(a->ounit>=MXUNIT || a->ounit<0) - err(a->oerr,101,"open") - if (!f__init) - f_init(); - f__curunit = b = &f__units[a->ounit]; - if(b->ufd) { - if(a->ofnm==0) - { - same: if (a->oblnk) - b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z'; - return(0); - } -#ifdef NON_UNIX_STDIO - if (b->ufnm - && strlen(b->ufnm) == a->ofnmlen - && !strncmp(b->ufnm, a->ofnm, (unsigned)a->ofnmlen)) - goto same; -#else - g_char(a->ofnm,a->ofnmlen,buf); - if (f__inode(buf,&n) == b->uinode && n == b->udev) - goto same; -#endif - x.cunit=a->ounit; - x.csta=0; - x.cerr=a->oerr; - if ((rv = f_clos(&x)) != 0) - return rv; - } - b->url = (int)a->orl; - b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z'); - if(a->ofm==0) - { if(b->url>0) b->ufmt=0; - else b->ufmt=1; - } - else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1; - else b->ufmt=0; - ufmt = b->ufmt; -#ifdef url_Adjust - if (b->url && !ufmt) - url_Adjust(b->url); -#endif - if (a->ofnm) { - g_char(a->ofnm,a->ofnmlen,buf); - if (!buf[0]) - opnerr(a->oerr,107,"open") - } - else - sprintf(buf, "fort.%ld", (long)a->ounit); - b->uscrtch = 0; - b->uend=0; - b->uwrt = 0; - b->ufd = 0; - b->urw = 3; - switch(a->osta ? *a->osta : 'u') - { - case 'o': - case 'O': -#ifdef NON_POSIX_STDIO - if (!(tf = FOPEN(buf,"r"))) - opnerr(a->oerr,errno,"open") - fclose(tf); -#else - if (ACCESS(buf,0)) - opnerr(a->oerr,errno,"open") -#endif - break; - case 's': - case 'S': - b->uscrtch=1; -#ifdef NON_ANSI_STDIO - (void) strcpy(buf,"tmp.FXXXXXX"); - (void) mktemp(buf); - goto replace; -#else - if (!(b->ufd = tmpfile())) - opnerr(a->oerr,errno,"open") - b->ufnm = 0; -#ifndef NON_UNIX_STDIO - b->uinode = b->udev = -1; -#endif - b->useek = 1; - return 0; -#endif - - case 'n': - case 'N': -#ifdef NON_POSIX_STDIO - if ((tf = FOPEN(buf,"r")) || (tf = FOPEN(buf,"a"))) { - fclose(tf); - opnerr(a->oerr,128,"open") - } -#else - if (!ACCESS(buf,0)) - opnerr(a->oerr,128,"open") -#endif - /* no break */ - case 'r': /* Fortran 90 replace option */ - case 'R': -#ifdef NON_ANSI_STDIO - replace: -#endif - if (tf = FOPEN(buf,f__w_mode[0])) - fclose(tf); - } - - b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1)); - if(b->ufnm==NULL) opnerr(a->oerr,113,"no space"); - (void) strcpy(b->ufnm,buf); - if ((s = a->oacc) && b->url) - ufmt = 0; - if(!(tf = FOPEN(buf, f__w_mode[ufmt|2]))) { - if (tf = FOPEN(buf, f__r_mode[ufmt])) - b->urw = 1; - else if (tf = FOPEN(buf, f__w_mode[ufmt])) { - b->uwrt = 1; - b->urw = 2; - } - else - err(a->oerr, errno, "open"); - } - b->useek = f__canseek(b->ufd = tf); -#ifndef NON_UNIX_STDIO - if((b->uinode = f__inode(buf,&b->udev)) == -1) - opnerr(a->oerr,108,"open") -#endif - if(b->useek) - if (a->orl) - rewind(b->ufd); - else if ((s = a->oacc) && (*s == 'a' || *s == 'A') - && FSEEK(b->ufd, 0L, SEEK_END)) - opnerr(a->oerr,129,"open"); - return(0); -} - - int -#ifdef KR_headers -fk_open(seq,fmt,n) ftnint n; -#else -fk_open(int seq, int fmt, ftnint n) -#endif -{ char nbuf[10]; - olist a; - (void) sprintf(nbuf,"fort.%ld",(long)n); - a.oerr=1; - a.ounit=n; - a.ofnm=nbuf; - a.ofnmlen= (ftnlen) strlen(nbuf); - a.osta=NULL; - a.oacc= (char*)(seq==SEQ?"s":"d"); - a.ofm = (char*)(fmt==FMT?"f":"u"); - a.orl = seq==DIR?1:0; - a.oblnk=NULL; - return(f_open(&a)); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/pow_ci.c b/ext/f2c_libs/pow_ci.c deleted file mode 100644 index 070622236..000000000 --- a/ext/f2c_libs/pow_ci.c +++ /dev/null @@ -1,26 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -VOID pow_ci(p, a, b) /* p = a**b */ - complex *p, *a; integer *b; -#else -extern void pow_zi(doublecomplex*, doublecomplex*, integer*); -void pow_ci(complex *p, complex *a, integer *b) /* p = a**b */ -#endif -{ -doublecomplex p1, a1; - -a1.r = a->r; -a1.i = a->i; - -pow_zi(&p1, &a1, b); - -p->r = (real) p1.r; -p->i = (real) p1.i; -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/pow_dd.c b/ext/f2c_libs/pow_dd.c deleted file mode 100644 index 08fc20884..000000000 --- a/ext/f2c_libs/pow_dd.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double pow(); -double pow_dd(ap, bp) doublereal *ap, *bp; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double pow_dd(doublereal *ap, doublereal *bp) -#endif -{ -return(pow(*ap, *bp) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/pow_di.c b/ext/f2c_libs/pow_di.c deleted file mode 100644 index abf36cb74..000000000 --- a/ext/f2c_libs/pow_di.c +++ /dev/null @@ -1,41 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -double pow_di(ap, bp) doublereal *ap; integer *bp; -#else -double pow_di(doublereal *ap, integer *bp) -#endif -{ -double pow, x; -integer n; -unsigned long u; - -pow = 1; -x = *ap; -n = *bp; - -if(n != 0) - { - if(n < 0) - { - n = -n; - x = 1/x; - } - for(u = n; ; ) - { - if(u & 01) - pow *= x; - if(u >>= 1) - x *= x; - else - break; - } - } -return(pow); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/pow_hh.c b/ext/f2c_libs/pow_hh.c deleted file mode 100644 index 882168501..000000000 --- a/ext/f2c_libs/pow_hh.c +++ /dev/null @@ -1,39 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -shortint pow_hh(ap, bp) shortint *ap, *bp; -#else -shortint pow_hh(shortint *ap, shortint *bp) -#endif -{ - shortint pow, x, n; - unsigned u; - - x = *ap; - n = *bp; - - if (n <= 0) { - if (n == 0 || x == 1) - return 1; - if (x != -1) - return x == 0 ? 1/x : 0; - n = -n; - } - u = n; - for(pow = 1; ; ) - { - if(u & 01) - pow *= x; - if(u >>= 1) - x *= x; - else - break; - } - return(pow); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/pow_ii.c b/ext/f2c_libs/pow_ii.c deleted file mode 100644 index 748d12177..000000000 --- a/ext/f2c_libs/pow_ii.c +++ /dev/null @@ -1,39 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -integer pow_ii(ap, bp) integer *ap, *bp; -#else -integer pow_ii(integer *ap, integer *bp) -#endif -{ - integer pow, x, n; - unsigned long u; - - x = *ap; - n = *bp; - - if (n <= 0) { - if (n == 0 || x == 1) - return 1; - if (x != -1) - return x == 0 ? 1/x : 0; - n = -n; - } - u = n; - for(pow = 1; ; ) - { - if(u & 01) - pow *= x; - if(u >>= 1) - x *= x; - else - break; - } - return(pow); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/pow_ri.c b/ext/f2c_libs/pow_ri.c deleted file mode 100644 index e29d416eb..000000000 --- a/ext/f2c_libs/pow_ri.c +++ /dev/null @@ -1,41 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -double pow_ri(ap, bp) real *ap; integer *bp; -#else -double pow_ri(real *ap, integer *bp) -#endif -{ -double pow, x; -integer n; -unsigned long u; - -pow = 1; -x = *ap; -n = *bp; - -if(n != 0) - { - if(n < 0) - { - n = -n; - x = 1/x; - } - for(u = n; ; ) - { - if(u & 01) - pow *= x; - if(u >>= 1) - x *= x; - else - break; - } - } -return(pow); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/pow_zi.c b/ext/f2c_libs/pow_zi.c deleted file mode 100644 index 1c0a4b07c..000000000 --- a/ext/f2c_libs/pow_zi.c +++ /dev/null @@ -1,60 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -VOID pow_zi(p, a, b) /* p = a**b */ - doublecomplex *p, *a; integer *b; -#else -extern void z_div(doublecomplex*, doublecomplex*, doublecomplex*); -void pow_zi(doublecomplex *p, doublecomplex *a, integer *b) /* p = a**b */ -#endif -{ - integer n; - unsigned long u; - double t; - doublecomplex q, x; - static doublecomplex one = {1.0, 0.0}; - - n = *b; - q.r = 1; - q.i = 0; - - if(n == 0) - goto done; - if(n < 0) - { - n = -n; - z_div(&x, &one, a); - } - else - { - x.r = a->r; - x.i = a->i; - } - - for(u = n; ; ) - { - if(u & 01) - { - t = q.r * x.r - q.i * x.i; - q.i = q.r * x.i + q.i * x.r; - q.r = t; - } - if(u >>= 1) - { - t = x.r * x.r - x.i * x.i; - x.i = 2 * x.r * x.i; - x.r = t; - } - else - break; - } - done: - p->i = q.i; - p->r = q.r; - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/pow_zz.c b/ext/f2c_libs/pow_zz.c deleted file mode 100644 index b5ffd3348..000000000 --- a/ext/f2c_libs/pow_zz.c +++ /dev/null @@ -1,29 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double log(), exp(), cos(), sin(), atan2(), f__cabs(); -VOID pow_zz(r,a,b) doublecomplex *r, *a, *b; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -extern double f__cabs(double,double); -void pow_zz(doublecomplex *r, doublecomplex *a, doublecomplex *b) -#endif -{ -double logr, logi, x, y; - -logr = log( f__cabs(a->r, a->i) ); -logi = atan2(a->i, a->r); - -x = exp( logr * b->r - logi * b->i ); -y = logr * b->i + logi * b->r; - -r->r = x * cos(y); -r->i = x * sin(y); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_abs.c b/ext/f2c_libs/r_abs.c deleted file mode 100644 index f3291fb4d..000000000 --- a/ext/f2c_libs/r_abs.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -double r_abs(x) real *x; -#else -double r_abs(real *x) -#endif -{ -if(*x >= 0) - return(*x); -return(- *x); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_acos.c b/ext/f2c_libs/r_acos.c deleted file mode 100644 index 103c7ff07..000000000 --- a/ext/f2c_libs/r_acos.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double acos(); -double r_acos(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double r_acos(real *x) -#endif -{ -return( acos(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_asin.c b/ext/f2c_libs/r_asin.c deleted file mode 100644 index 432b9406a..000000000 --- a/ext/f2c_libs/r_asin.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double asin(); -double r_asin(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double r_asin(real *x) -#endif -{ -return( asin(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_atan.c b/ext/f2c_libs/r_atan.c deleted file mode 100644 index 7656982db..000000000 --- a/ext/f2c_libs/r_atan.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double atan(); -double r_atan(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double r_atan(real *x) -#endif -{ -return( atan(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_atn2.c b/ext/f2c_libs/r_atn2.c deleted file mode 100644 index ab957b89d..000000000 --- a/ext/f2c_libs/r_atn2.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double atan2(); -double r_atn2(x,y) real *x, *y; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double r_atn2(real *x, real *y) -#endif -{ -return( atan2(*x,*y) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_cnjg.c b/ext/f2c_libs/r_cnjg.c deleted file mode 100644 index cef0e4b09..000000000 --- a/ext/f2c_libs/r_cnjg.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -VOID r_cnjg(r, z) complex *r, *z; -#else -VOID r_cnjg(complex *r, complex *z) -#endif -{ - real zi = z->i; - r->r = z->r; - r->i = -zi; - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_cos.c b/ext/f2c_libs/r_cos.c deleted file mode 100644 index 4418f0c1b..000000000 --- a/ext/f2c_libs/r_cos.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double cos(); -double r_cos(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double r_cos(real *x) -#endif -{ -return( cos(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_cosh.c b/ext/f2c_libs/r_cosh.c deleted file mode 100644 index f54783558..000000000 --- a/ext/f2c_libs/r_cosh.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double cosh(); -double r_cosh(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double r_cosh(real *x) -#endif -{ -return( cosh(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_dim.c b/ext/f2c_libs/r_dim.c deleted file mode 100644 index d573ca36d..000000000 --- a/ext/f2c_libs/r_dim.c +++ /dev/null @@ -1,16 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -double r_dim(a,b) real *a, *b; -#else -double r_dim(real *a, real *b) -#endif -{ -return( *a > *b ? *a - *b : 0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_exp.c b/ext/f2c_libs/r_exp.c deleted file mode 100644 index 4e679794f..000000000 --- a/ext/f2c_libs/r_exp.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double exp(); -double r_exp(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double r_exp(real *x) -#endif -{ -return( exp(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_imag.c b/ext/f2c_libs/r_imag.c deleted file mode 100644 index 1b4de1437..000000000 --- a/ext/f2c_libs/r_imag.c +++ /dev/null @@ -1,16 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -double r_imag(z) complex *z; -#else -double r_imag(complex *z) -#endif -{ -return(z->i); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_int.c b/ext/f2c_libs/r_int.c deleted file mode 100644 index bff87176f..000000000 --- a/ext/f2c_libs/r_int.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double floor(); -double r_int(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double r_int(real *x) -#endif -{ -return( (*x>0) ? floor(*x) : -floor(- *x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_lg10.c b/ext/f2c_libs/r_lg10.c deleted file mode 100644 index 64ffddf48..000000000 --- a/ext/f2c_libs/r_lg10.c +++ /dev/null @@ -1,21 +0,0 @@ -#include "f2c.h" - -#define log10e 0.43429448190325182765 - -#ifdef KR_headers -double log(); -double r_lg10(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double r_lg10(real *x) -#endif -{ -return( log10e * log(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_log.c b/ext/f2c_libs/r_log.c deleted file mode 100644 index 94c79b051..000000000 --- a/ext/f2c_libs/r_log.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double log(); -double r_log(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double r_log(real *x) -#endif -{ -return( log(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_mod.c b/ext/f2c_libs/r_mod.c deleted file mode 100644 index 63ed17536..000000000 --- a/ext/f2c_libs/r_mod.c +++ /dev/null @@ -1,46 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -#ifdef IEEE_drem -double drem(); -#else -double floor(); -#endif -double r_mod(x,y) real *x, *y; -#else -#ifdef IEEE_drem -double drem(double, double); -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -#endif -double r_mod(real *x, real *y) -#endif -{ -#ifdef IEEE_drem - double xa, ya, z; - if ((ya = *y) < 0.) - ya = -ya; - z = drem(xa = *x, ya); - if (xa > 0) { - if (z < 0) - z += ya; - } - else if (z > 0) - z -= ya; - return z; -#else - double quotient; - if( (quotient = (double)*x / *y) >= 0) - quotient = floor(quotient); - else - quotient = -floor(-quotient); - return(*x - (*y) * quotient ); -#endif -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_nint.c b/ext/f2c_libs/r_nint.c deleted file mode 100644 index 7cc3f1b5a..000000000 --- a/ext/f2c_libs/r_nint.c +++ /dev/null @@ -1,20 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double floor(); -double r_nint(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double r_nint(real *x) -#endif -{ -return( (*x)>=0 ? - floor(*x + .5) : -floor(.5 - *x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_sign.c b/ext/f2c_libs/r_sign.c deleted file mode 100644 index 797db1a4c..000000000 --- a/ext/f2c_libs/r_sign.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -double r_sign(a,b) real *a, *b; -#else -double r_sign(real *a, real *b) -#endif -{ -double x; -x = (*a >= 0 ? *a : - *a); -return( *b >= 0 ? x : -x); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_sin.c b/ext/f2c_libs/r_sin.c deleted file mode 100644 index 37e0df25f..000000000 --- a/ext/f2c_libs/r_sin.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double sin(); -double r_sin(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double r_sin(real *x) -#endif -{ -return( sin(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_sinh.c b/ext/f2c_libs/r_sinh.c deleted file mode 100644 index 39878f03a..000000000 --- a/ext/f2c_libs/r_sinh.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double sinh(); -double r_sinh(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double r_sinh(real *x) -#endif -{ -return( sinh(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_sqrt.c b/ext/f2c_libs/r_sqrt.c deleted file mode 100644 index e7b2c1c70..000000000 --- a/ext/f2c_libs/r_sqrt.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double sqrt(); -double r_sqrt(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double r_sqrt(real *x) -#endif -{ -return( sqrt(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_tan.c b/ext/f2c_libs/r_tan.c deleted file mode 100644 index 1774bed73..000000000 --- a/ext/f2c_libs/r_tan.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double tan(); -double r_tan(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double r_tan(real *x) -#endif -{ -return( tan(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/r_tanh.c b/ext/f2c_libs/r_tanh.c deleted file mode 100644 index 7739c6ce8..000000000 --- a/ext/f2c_libs/r_tanh.c +++ /dev/null @@ -1,19 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double tanh(); -double r_tanh(x) real *x; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -double r_tanh(real *x) -#endif -{ -return( tanh(*x) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/rawio.h b/ext/f2c_libs/rawio.h deleted file mode 100644 index fd36a4826..000000000 --- a/ext/f2c_libs/rawio.h +++ /dev/null @@ -1,41 +0,0 @@ -#ifndef KR_headers -#ifdef MSDOS -#include "io.h" -#ifndef WATCOM -#define close _close -#define creat _creat -#define open _open -#define read _read -#define write _write -#endif /*WATCOM*/ -#endif /*MSDOS*/ -#ifdef __cplusplus -extern "C" { -#endif -#ifndef MSDOS -#ifdef OPEN_DECL -extern int creat(const char*,int), open(const char*,int); -#endif -extern int close(int); -extern int read(int,void*,size_t), write(int,void*,size_t); -extern int unlink(const char*); -#ifndef _POSIX_SOURCE -#ifndef NON_UNIX_STDIO -extern FILE *fdopen(int, const char*); -#endif -#endif -#endif /*KR_HEADERS*/ - -extern char *mktemp(char*); - -#ifdef __cplusplus - } -#endif -#endif - -#include "fcntl.h" - -#ifndef O_WRONLY -#define O_RDONLY 0 -#define O_WRONLY 1 -#endif diff --git a/ext/f2c_libs/rdfmt.c b/ext/f2c_libs/rdfmt.c deleted file mode 100644 index 817d379b9..000000000 --- a/ext/f2c_libs/rdfmt.c +++ /dev/null @@ -1,550 +0,0 @@ -#include "f2c.h" -#include "fio.h" - -#ifdef KR_headers -extern double atof(); -#else -#undef abs -#undef min -#undef max -#include "stdlib.h" -#endif - -#include "fmt.h" -#include "fp.h" -#include "ctype.h" -#ifdef __cplusplus -extern "C" { -#endif - - static int -#ifdef KR_headers -rd_Z(n,w,len) Uint *n; ftnlen len; -#else -rd_Z(Uint *n, int w, ftnlen len) -#endif -{ - long x[9]; - char *s, *s0, *s1, *se, *t; - int ch, i, w1, w2; - static char hex[256]; - static int one = 1; - int bad = 0; - - if (!hex['0']) { - s = "0123456789"; - while(ch = *s++) - hex[ch] = ch - '0' + 1; - s = "ABCDEF"; - while(ch = *s++) - hex[ch] = hex[ch + 'a' - 'A'] = ch - 'A' + 11; - } - s = s0 = (char *)x; - s1 = (char *)&x[4]; - se = (char *)&x[8]; - if (len > 4*sizeof(long)) - return errno = 117; - while (w) { - GET(ch); - if (ch==',' || ch=='\n') - break; - w--; - if (ch > ' ') { - if (!hex[ch & 0xff]) - bad++; - *s++ = ch; - if (s == se) { - /* discard excess characters */ - for(t = s0, s = s1; t < s1;) - *t++ = *s++; - s = s1; - } - } - } - if (bad) - return errno = 115; - w = (int)len; - w1 = (int) (s - s0); - w2 = (w1+1) >> 1; - t = (char *)n; - if (*(char *)&one) { - /* little endian */ - t += w - 1; - i = -1; - } - else - i = 1; - for(; w > w2; t += i, --w) - *t = 0; - if (!w) - return 0; - if (w < w2) - s0 = s - (w << 1); - else if (w1 & 1) { - *t = hex[*s0++ & 0xff] - 1; - if (!--w) - return 0; - t += i; - } - do { - *t = (hex[*s0 & 0xff]-1) << 4 | hex[s0[1] & 0xff]-1; - t += i; - s0 += 2; - } - while(--w); - return 0; - } - - static int -#ifdef KR_headers -rd_I(n,w,len, base) Uint *n; int w; ftnlen len; register int base; -#else -rd_I(Uint *n, int w, ftnlen len, register int base) -#endif -{ - int ch, sign; - longint x = 0; - - if (w <= 0) - goto have_x; - for(;;) { - GET(ch); - if (ch != ' ') - break; - if (!--w) - goto have_x; - } - sign = 0; - switch(ch) { - case ',': - case '\n': - w = 0; - goto have_x; - case '-': - sign = 1; - case '+': - break; - default: - if (ch >= '0' && ch <= '9') { - x = ch - '0'; - break; - } - goto have_x; - } - while(--w) { - GET(ch); - if (ch >= '0' && ch <= '9') { - x = x*base + ch - '0'; - continue; - } - if (ch != ' ') { - if (ch == '\n' || ch == ',') - w = 0; - break; - } - if (f__cblank) - x *= base; - } - if (sign) - x = -x; - have_x: - if(len == sizeof(integer)) - n->il=x; - else if(len == sizeof(char)) - n->ic = (char)x; -#ifdef Allow_TYQUAD - else if (len == sizeof(longint)) - n->ili = x; -#endif - else - n->is = (short)x; - if (w) { - while(--w) - GET(ch); - return errno = 115; - } - return 0; -} - - static int -#ifdef KR_headers -rd_L(n,w,len) ftnint *n; ftnlen len; -#else -rd_L(ftnint *n, int w, ftnlen len) -#endif -{ int ch, dot, lv; - - if (w <= 0) - goto bad; - for(;;) { - GET(ch); - --w; - if (ch != ' ') - break; - if (!w) - goto bad; - } - dot = 0; - retry: - switch(ch) { - case '.': - if (dot++ || !w) - goto bad; - GET(ch); - --w; - goto retry; - case 't': - case 'T': - lv = 1; - break; - case 'f': - case 'F': - lv = 0; - break; - default: - bad: - for(; w > 0; --w) - GET(ch); - /* no break */ - case ',': - case '\n': - return errno = 116; - } - switch(len) { - case sizeof(char): *(char *)n = (char)lv; break; - case sizeof(short): *(short *)n = (short)lv; break; - default: *n = lv; - } - while(w-- > 0) { - GET(ch); - if (ch == ',' || ch == '\n') - break; - } - return 0; -} - - static int -#ifdef KR_headers -rd_F(p, w, d, len) ufloat *p; ftnlen len; -#else -rd_F(ufloat *p, int w, int d, ftnlen len) -#endif -{ - char s[FMAX+EXPMAXDIGS+4]; - register int ch; - register char *sp, *spe, *sp1; - double x; - int scale1, se; - long e, exp; - - sp1 = sp = s; - spe = sp + FMAX; - exp = -d; - x = 0.; - - do { - GET(ch); - w--; - } while (ch == ' ' && w); - switch(ch) { - case '-': *sp++ = ch; sp1++; spe++; - case '+': - if (!w) goto zero; - --w; - GET(ch); - } - while(ch == ' ') { -blankdrop: - if (!w--) goto zero; GET(ch); } - while(ch == '0') - { if (!w--) goto zero; GET(ch); } - if (ch == ' ' && f__cblank) - goto blankdrop; - scale1 = f__scale; - while(isdigit(ch)) { -digloop1: - if (sp < spe) *sp++ = ch; - else ++exp; -digloop1e: - if (!w--) goto done; - GET(ch); - } - if (ch == ' ') { - if (f__cblank) - { ch = '0'; goto digloop1; } - goto digloop1e; - } - if (ch == '.') { - exp += d; - if (!w--) goto done; - GET(ch); - if (sp == sp1) { /* no digits yet */ - while(ch == '0') { -skip01: - --exp; -skip0: - if (!w--) goto done; - GET(ch); - } - if (ch == ' ') { - if (f__cblank) goto skip01; - goto skip0; - } - } - while(isdigit(ch)) { -digloop2: - if (sp < spe) - { *sp++ = ch; --exp; } -digloop2e: - if (!w--) goto done; - GET(ch); - } - if (ch == ' ') { - if (f__cblank) - { ch = '0'; goto digloop2; } - goto digloop2e; - } - } - switch(ch) { - default: - break; - case '-': se = 1; goto signonly; - case '+': se = 0; goto signonly; - case 'e': - case 'E': - case 'd': - case 'D': - if (!w--) - goto bad; - GET(ch); - while(ch == ' ') { - if (!w--) - goto bad; - GET(ch); - } - se = 0; - switch(ch) { - case '-': se = 1; - case '+': -signonly: - if (!w--) - goto bad; - GET(ch); - } - while(ch == ' ') { - if (!w--) - goto bad; - GET(ch); - } - if (!isdigit(ch)) - goto bad; - - e = ch - '0'; - for(;;) { - if (!w--) - { ch = '\n'; break; } - GET(ch); - if (!isdigit(ch)) { - if (ch == ' ') { - if (f__cblank) - ch = '0'; - else continue; - } - else - break; - } - e = 10*e + ch - '0'; - if (e > EXPMAX && sp > sp1) - goto bad; - } - if (se) - exp -= e; - else - exp += e; - scale1 = 0; - } - switch(ch) { - case '\n': - case ',': - break; - default: -bad: - return (errno = 115); - } -done: - if (sp > sp1) { - while(*--sp == '0') - ++exp; - if (exp -= scale1) - sprintf(sp+1, "e%ld", exp); - else - sp[1] = 0; - x = atof(s); - } -zero: - if (len == sizeof(real)) - p->pf = (real) x; - else - p->pd = x; - return(0); - } - - - static int -#ifdef KR_headers -rd_A(p,len) char *p; ftnlen len; -#else -rd_A(char *p, ftnlen len) -#endif -{ int i,ch; - for(i=0;i=len) - { for(i=0;i0;f__cursor--) if((ch=(*f__getn)())<0) return(ch); - if(f__cursor<0) - { if(f__recpos+f__cursor < 0) /*err(elist->cierr,110,"fmt")*/ - f__cursor = -f__recpos; /* is this in the standard? */ - if(f__external == 0) { - extern char *f__icptr; - f__icptr += f__cursor; - } - else if(f__curunit && f__curunit->useek) - (void) FSEEK(f__cf, f__cursor,SEEK_CUR); - else - err(f__elist->cierr,106,"fmt"); - f__recpos += f__cursor; - f__cursor=0; - } - switch(p->op) - { - default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op); - sig_die(f__fmtbuf, 1); - case IM: - case I: ch = rd_I((Uint *)ptr,p->p1,len, 10); - break; - - /* O and OM don't work right for character, double, complex, */ - /* or doublecomplex, and they differ from Fortran 90 in */ - /* showing a minus sign for negative values. */ - - case OM: - case O: ch = rd_I((Uint *)ptr, p->p1, len, 8); - break; - case L: ch = rd_L((ftnint *)ptr,p->p1,len); - break; - case A: ch = rd_A(ptr,len); - break; - case AW: - ch = rd_AW(ptr,p->p1,len); - break; - case E: case EE: - case D: - case G: - case GE: - case F: ch = rd_F((ufloat *)ptr,p->p1,p->p2.i[0],len); - break; - - /* Z and ZM assume 8-bit bytes. */ - - case ZM: - case Z: - ch = rd_Z((Uint *)ptr, p->p1, len); - break; - } - if(ch == 0) return(ch); - else if(ch == EOF) return(EOF); - if (f__cf) - clearerr(f__cf); - return(errno); -} - - int -#ifdef KR_headers -rd_ned(p) struct syl *p; -#else -rd_ned(struct syl *p) -#endif -{ - switch(p->op) - { - default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op); - sig_die(f__fmtbuf, 1); - case APOS: - return(rd_POS(p->p2.s)); - case H: return(rd_H(p->p1,p->p2.s)); - case SLASH: return((*f__donewrec)()); - case TR: - case X: f__cursor += p->p1; - return(1); - case T: f__cursor=p->p1-f__recpos - 1; - return(1); - case TL: f__cursor -= p->p1; - if(f__cursor < -f__recpos) /* TL1000, 1X */ - f__cursor = -f__recpos; - return(1); - } -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/rewind.c b/ext/f2c_libs/rewind.c deleted file mode 100644 index 9a0e07e6c..000000000 --- a/ext/f2c_libs/rewind.c +++ /dev/null @@ -1,30 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#ifdef __cplusplus -extern "C" { -#endif -#ifdef KR_headers -integer f_rew(a) alist *a; -#else -integer f_rew(alist *a) -#endif -{ - unit *b; - if(a->aunit>=MXUNIT || a->aunit<0) - err(a->aerr,101,"rewind"); - b = &f__units[a->aunit]; - if(b->ufd == NULL || b->uwrt == 3) - return(0); - if(!b->useek) - err(a->aerr,106,"rewind") - if(b->uwrt) { - (void) t_runc(a); - b->uwrt = 3; - } - rewind(b->ufd); - b->uend=0; - return(0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/rsfe.c b/ext/f2c_libs/rsfe.c deleted file mode 100644 index abe9724a7..000000000 --- a/ext/f2c_libs/rsfe.c +++ /dev/null @@ -1,91 +0,0 @@ -/* read sequential formatted external */ -#include "f2c.h" -#include "fio.h" -#include "fmt.h" -#ifdef __cplusplus -extern "C" { -#endif - - int -xrd_SL(Void) -{ int ch; - if(!f__curunit->uend) - while((ch=getc(f__cf))!='\n') - if (ch == EOF) { - f__curunit->uend = 1; - break; - } - f__cursor=f__recpos=0; - return(1); -} - - int -x_getc(Void) -{ int ch; - if(f__curunit->uend) return(EOF); - ch = getc(f__cf); - if(ch!=EOF && ch!='\n') - { f__recpos++; - return(ch); - } - if(ch=='\n') - { (void) ungetc(ch,f__cf); - return(ch); - } - if(f__curunit->uend || feof(f__cf)) - { errno=0; - f__curunit->uend=1; - return(-1); - } - return(-1); -} - - int -x_endp(Void) -{ - xrd_SL(); - return f__curunit->uend == 1 ? EOF : 0; -} - - int -x_rev(Void) -{ - (void) xrd_SL(); - return(0); -} -#ifdef KR_headers -integer s_rsfe(a) cilist *a; /* start */ -#else -integer s_rsfe(cilist *a) /* start */ -#endif -{ int n; - if(!f__init) f_init(); - f__reading=1; - f__sequential=1; - f__formatted=1; - f__external=1; - if(n=c_sfe(a)) return(n); - f__elist=a; - f__cursor=f__recpos=0; - f__scale=0; - f__fmtbuf=a->cifmt; - f__cf=f__curunit->ufd; - if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); - f__getn= x_getc; - f__doed= rd_ed; - f__doned= rd_ned; - fmt_bg(); - f__doend=x_endp; - f__donewrec=xrd_SL; - f__dorevert=x_rev; - f__cblank=f__curunit->ublnk; - f__cplus=0; - if(f__curunit->uwrt && f__nowreading(f__curunit)) - err(a->cierr,errno,"read start"); - if(f__curunit->uend) - err(f__elist->ciend,(EOF),"read start"); - return(0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/rsli.c b/ext/f2c_libs/rsli.c deleted file mode 100644 index 3d4ea428f..000000000 --- a/ext/f2c_libs/rsli.c +++ /dev/null @@ -1,109 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#include "lio.h" -#include "fmt.h" /* for f__doend */ -#ifdef __cplusplus -extern "C" { -#endif - -extern flag f__lquit; -extern int f__lcount; -extern char *f__icptr; -extern char *f__icend; -extern icilist *f__svic; -extern int f__icnum, f__recpos; - -static int i_getc(Void) -{ - if(f__recpos >= f__svic->icirlen) { - if (f__recpos++ == f__svic->icirlen) - return '\n'; - z_rnew(); - } - f__recpos++; - if(f__icptr >= f__icend) - return EOF; - return(*f__icptr++); - } - - static -#ifdef KR_headers -int i_ungetc(ch, f) int ch; FILE *f; -#else -int i_ungetc(int ch, FILE *f) -#endif -{ - if (--f__recpos == f__svic->icirlen) - return '\n'; - if (f__recpos < -1) - err(f__svic->icierr,110,"recend"); - /* *--icptr == ch, and icptr may point to read-only memory */ - return *--f__icptr /* = ch */; - } - - static void -#ifdef KR_headers -c_lir(a) icilist *a; -#else -c_lir(icilist *a) -#endif -{ - extern int l_eof; - f__reading = 1; - f__external = 0; - f__formatted = 1; - f__svic = a; - L_len = a->icirlen; - f__recpos = -1; - f__icnum = f__recpos = 0; - f__cursor = 0; - l_getc = i_getc; - l_ungetc = i_ungetc; - l_eof = 0; - f__icptr = a->iciunit; - f__icend = f__icptr + a->icirlen*a->icirnum; - f__cf = 0; - f__curunit = 0; - f__elist = (cilist *)a; - } - - -#ifdef KR_headers -integer s_rsli(a) icilist *a; -#else -integer s_rsli(icilist *a) -#endif -{ - f__lioproc = l_read; - f__lquit = 0; - f__lcount = 0; - c_lir(a); - f__doend = 0; - return(0); - } - -integer e_rsli(Void) -{ return 0; } - -#ifdef KR_headers -integer s_rsni(a) icilist *a; -#else -extern int x_rsne(cilist*); - -integer s_rsni(icilist *a) -#endif -{ - extern int nml_read; - integer rv; - cilist ca; - ca.ciend = a->iciend; - ca.cierr = a->icierr; - ca.cifmt = a->icifmt; - c_lir(a); - rv = x_rsne(&ca); - nml_read = 0; - return rv; - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/rsne.c b/ext/f2c_libs/rsne.c deleted file mode 100644 index 9dc18846e..000000000 --- a/ext/f2c_libs/rsne.c +++ /dev/null @@ -1,618 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#include "lio.h" - -#define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */ -#define MAXDIM 20 /* maximum number of subscripts */ - - struct dimen { - ftnlen extent; - ftnlen curval; - ftnlen delta; - ftnlen stride; - }; - typedef struct dimen dimen; - - struct hashentry { - struct hashentry *next; - char *name; - Vardesc *vd; - }; - typedef struct hashentry hashentry; - - struct hashtab { - struct hashtab *next; - Namelist *nl; - int htsize; - hashentry *tab[1]; - }; - typedef struct hashtab hashtab; - - static hashtab *nl_cache; - static int n_nlcache; - static hashentry **zot; - static int colonseen; - extern ftnlen f__typesize[]; - - extern flag f__lquit; - extern int f__lcount, nml_read; - extern int t_getc(Void); - -#ifdef KR_headers - extern char *malloc(), *memset(); - -#ifdef ungetc - static int -un_getc(x,f__cf) int x; FILE *f__cf; -{ return ungetc(x,f__cf); } -#else -#define un_getc ungetc - extern int ungetc(); -#endif - -#else -#undef abs -#undef min -#undef max -#include "stdlib.h" -#include "string.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef ungetc - static int -un_getc(int x, FILE *f__cf) -{ return ungetc(x,f__cf); } -#else -#define un_getc ungetc -#ifndef _WIN32 -extern int ungetc(int, FILE*); /* for systems with a buggy stdio.h */ -#endif -#endif -#endif - - static Vardesc * -#ifdef KR_headers -hash(ht, s) hashtab *ht; register char *s; -#else -hash(hashtab *ht, register char *s) -#endif -{ - register int c, x; - register hashentry *h; - char *s0 = s; - - for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1) - x += c; - for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next) - if (!strcmp(s0, h->name)) - return h->vd; - return 0; - } - - hashtab * -#ifdef KR_headers -mk_hashtab(nl) Namelist *nl; -#else -mk_hashtab(Namelist *nl) -#endif -{ - int nht, nv; - hashtab *ht; - Vardesc *v, **vd, **vde; - hashentry *he; - - hashtab **x, **x0, *y; - for(x = &nl_cache; y = *x; x0 = x, x = &y->next) - if (nl == y->nl) - return y; - if (n_nlcache >= MAX_NL_CACHE) { - /* discard least recently used namelist hash table */ - y = *x0; - free((char *)y->next); - y->next = 0; - } - else - n_nlcache++; - nv = nl->nvars; - if (nv >= 0x4000) - nht = 0x7fff; - else { - for(nht = 1; nht < nv; nht <<= 1); - nht += nht - 1; - } - ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *) - + nv*sizeof(hashentry)); - if (!ht) - return 0; - he = (hashentry *)&ht->tab[nht]; - ht->nl = nl; - ht->htsize = nht; - ht->next = nl_cache; - nl_cache = ht; - memset((char *)ht->tab, 0, nht*sizeof(hashentry *)); - vd = nl->vars; - vde = vd + nv; - while(vd < vde) { - v = *vd++; - if (!hash(ht, v->name)) { - he->next = *zot; - *zot = he; - he->name = v->name; - he->vd = v; - he++; - } - } - return ht; - } - -static char Alpha[256], Alphanum[256]; - - static VOID -nl_init(Void) { - register char *s; - register int c; - - if(!f__init) - f_init(); - for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; ) - Alpha[c] - = Alphanum[c] - = Alpha[c + 'a' - 'A'] - = Alphanum[c + 'a' - 'A'] - = c; - for(s = "0123456789_"; c = *s++; ) - Alphanum[c] = c; - } - -#define GETC(x) (x=(*l_getc)()) -#define Ungetc(x,y) (*l_ungetc)(x,y) - - static int -#ifdef KR_headers -getname(s, slen) register char *s; int slen; -#else -getname(register char *s, int slen) -#endif -{ - register char *se = s + slen - 1; - register int ch; - - GETC(ch); - if (!(*s++ = Alpha[ch & 0xff])) { - if (ch != EOF) - ch = 115; - errfl(f__elist->cierr, ch, "namelist read"); - } - while(*s = Alphanum[GETC(ch) & 0xff]) - if (s < se) - s++; - if (ch == EOF) - err(f__elist->cierr, EOF, "namelist read"); - if (ch > ' ') - Ungetc(ch,f__cf); - return *s = 0; - } - - static int -#ifdef KR_headers -getnum(chp, val) int *chp; ftnlen *val; -#else -getnum(int *chp, ftnlen *val) -#endif -{ - register int ch, sign; - register ftnlen x; - - while(GETC(ch) <= ' ' && ch >= 0); - if (ch == '-') { - sign = 1; - GETC(ch); - } - else { - sign = 0; - if (ch == '+') - GETC(ch); - } - x = ch - '0'; - if (x < 0 || x > 9) - return 115; - while(GETC(ch) >= '0' && ch <= '9') - x = 10*x + ch - '0'; - while(ch <= ' ' && ch >= 0) - GETC(ch); - if (ch == EOF) - return EOF; - *val = sign ? -x : x; - *chp = ch; - return 0; - } - - static int -#ifdef KR_headers -getdimen(chp, d, delta, extent, x1) - int *chp; dimen *d; ftnlen delta, extent, *x1; -#else -getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1) -#endif -{ - register int k; - ftnlen x2, x3; - - if (k = getnum(chp, x1)) - return k; - x3 = 1; - if (*chp == ':') { - if (k = getnum(chp, &x2)) - return k; - x2 -= *x1; - if (*chp == ':') { - if (k = getnum(chp, &x3)) - return k; - if (!x3) - return 123; - x2 /= x3; - colonseen = 1; - } - if (x2 < 0 || x2 >= extent) - return 123; - d->extent = x2 + 1; - } - else - d->extent = 1; - d->curval = 0; - d->delta = delta; - d->stride = x3; - return 0; - } - -#ifndef No_Namelist_Questions - static Void -#ifdef KR_headers -print_ne(a) cilist *a; -#else -print_ne(cilist *a) -#endif -{ - flag intext = f__external; - int rpsave = f__recpos; - FILE *cfsave = f__cf; - unit *usave = f__curunit; - cilist t; - t = *a; - t.ciunit = 6; - s_wsne(&t); - fflush(f__cf); - f__external = intext; - f__reading = 1; - f__recpos = rpsave; - f__cf = cfsave; - f__curunit = usave; - f__elist = a; - } -#endif - - static char where0[] = "namelist read start "; - - int -#ifdef KR_headers -x_rsne(a) cilist *a; -#else -x_rsne(cilist *a) -#endif -{ - int ch, got1, k, n, nd, quote, readall; - Namelist *nl; - static char where[] = "namelist read"; - char buf[64]; - hashtab *ht; - Vardesc *v; - dimen *dn, *dn0, *dn1; - ftnlen *dims, *dims1; - ftnlen b, b0, b1, ex, no, nomax, size, span; - ftnint no1, no2, type; - char *vaddr; - long iva, ivae; - dimen dimens[MAXDIM], substr; - - if (!Alpha['a']) - nl_init(); - f__reading=1; - f__formatted=1; - got1 = 0; - top: - for(;;) switch(GETC(ch)) { - case EOF: - eof: - err(a->ciend,(EOF),where0); - case '&': - case '$': - goto have_amp; -#ifndef No_Namelist_Questions - case '?': - print_ne(a); - continue; -#endif - default: - if (ch <= ' ' && ch >= 0) - continue; -#ifndef No_Namelist_Comments - while(GETC(ch) != '\n') - if (ch == EOF) - goto eof; -#else - errfl(a->cierr, 115, where0); -#endif - } - have_amp: - if (ch = getname(buf,sizeof(buf))) - return ch; - nl = (Namelist *)a->cifmt; - if (strcmp(buf, nl->name)) -#ifdef No_Bad_Namelist_Skip - errfl(a->cierr, 118, where0); -#else - { - fprintf(stderr, - "Skipping namelist \"%s\": seeking namelist \"%s\".\n", - buf, nl->name); - fflush(stderr); - for(;;) switch(GETC(ch)) { - case EOF: - err(a->ciend, EOF, where0); - case '/': - case '&': - case '$': - if (f__external) - e_rsle(); - else - z_rnew(); - goto top; - case '"': - case '\'': - quote = ch; - more_quoted: - while(GETC(ch) != quote) - if (ch == EOF) - err(a->ciend, EOF, where0); - if (GETC(ch) == quote) - goto more_quoted; - Ungetc(ch,f__cf); - default: - continue; - } - } -#endif - ht = mk_hashtab(nl); - if (!ht) - errfl(f__elist->cierr, 113, where0); - for(;;) { - for(;;) switch(GETC(ch)) { - case EOF: - if (got1) - return 0; - err(a->ciend, EOF, where0); - case '/': - case '$': - case '&': - return 0; - default: - if (ch <= ' ' && ch >= 0 || ch == ',') - continue; - Ungetc(ch,f__cf); - if (ch = getname(buf,sizeof(buf))) - return ch; - goto havename; - } - havename: - v = hash(ht,buf); - if (!v) - errfl(a->cierr, 119, where); - while(GETC(ch) <= ' ' && ch >= 0); - vaddr = v->addr; - type = v->type; - if (type < 0) { - size = -type; - type = TYCHAR; - } - else - size = f__typesize[type]; - ivae = size; - iva = readall = 0; - if (ch == '(' /*)*/ ) { - dn = dimens; - if (!(dims = v->dims)) { - if (type != TYCHAR) - errfl(a->cierr, 122, where); - if (k = getdimen(&ch, dn, (ftnlen)size, - (ftnlen)size, &b)) - errfl(a->cierr, k, where); - if (ch != ')') - errfl(a->cierr, 115, where); - b1 = dn->extent; - if (--b < 0 || b + b1 > size) - return 124; - iva += b; - size = b1; - while(GETC(ch) <= ' ' && ch >= 0); - goto scalar; - } - nd = (int)dims[0]; - nomax = span = dims[1]; - ivae = iva + size*nomax; - colonseen = 0; - if (k = getdimen(&ch, dn, size, nomax, &b)) - errfl(a->cierr, k, where); - no = dn->extent; - b0 = dims[2]; - dims1 = dims += 3; - ex = 1; - for(n = 1; n++ < nd; dims++) { - if (ch != ',') - errfl(a->cierr, 115, where); - dn1 = dn + 1; - span /= *dims; - if (k = getdimen(&ch, dn1, dn->delta**dims, - span, &b1)) - errfl(a->cierr, k, where); - ex *= *dims; - b += b1*ex; - no *= dn1->extent; - dn = dn1; - } - if (ch != ')') - errfl(a->cierr, 115, where); - readall = 1 - colonseen; - b -= b0; - if (b < 0 || b >= nomax) - errfl(a->cierr, 125, where); - iva += size * b; - dims = dims1; - while(GETC(ch) <= ' ' && ch >= 0); - no1 = 1; - dn0 = dimens; - if (type == TYCHAR && ch == '(' /*)*/) { - if (k = getdimen(&ch, &substr, size, size, &b)) - errfl(a->cierr, k, where); - if (ch != ')') - errfl(a->cierr, 115, where); - b1 = substr.extent; - if (--b < 0 || b + b1 > size) - return 124; - iva += b; - b0 = size; - size = b1; - while(GETC(ch) <= ' ' && ch >= 0); - if (b1 < b0) - goto delta_adj; - } - if (readall) - goto delta_adj; - for(; dn0 < dn; dn0++) { - if (dn0->extent != *dims++ || dn0->stride != 1) - break; - no1 *= dn0->extent; - } - if (dn0 == dimens && dimens[0].stride == 1) { - no1 = dimens[0].extent; - dn0++; - } - delta_adj: - ex = 0; - for(dn1 = dn0; dn1 <= dn; dn1++) - ex += (dn1->extent-1) - * (dn1->delta *= dn1->stride); - for(dn1 = dn; dn1 > dn0; dn1--) { - ex -= (dn1->extent - 1) * dn1->delta; - dn1->delta -= ex; - } - } - else if (dims = v->dims) { - no = no1 = dims[1]; - ivae = iva + no*size; - } - else - scalar: - no = no1 = 1; - if (ch != '=') - errfl(a->cierr, 115, where); - got1 = nml_read = 1; - f__lcount = 0; - readloop: - for(;;) { - if (iva >= ivae || iva < 0) { - f__lquit = 1; - goto mustend; - } - else if (iva + no1*size > ivae) - no1 = (ivae - iva)/size; - f__lquit = 0; - if (k = l_read(&no1, vaddr + iva, size, type)) - return k; - if (f__lquit == 1) - return 0; - if (readall) { - iva += dn0->delta; - if (f__lcount > 0) { - no2 = (ivae - iva)/size; - if (no2 > f__lcount) - no2 = f__lcount; - if (k = l_read(&no2, vaddr + iva, - size, type)) - return k; - iva += no2 * dn0->delta; - } - } - mustend: - GETC(ch); - if (readall) - if (iva >= ivae) - readall = 0; - else for(;;) { - switch(ch) { - case ' ': - case '\t': - case '\n': - GETC(ch); - continue; - } - break; - } - if (ch == '/' || ch == '$' || ch == '&') { - f__lquit = 1; - return 0; - } - else if (f__lquit) { - while(ch <= ' ' && ch >= 0) - GETC(ch); - Ungetc(ch,f__cf); - if (!Alpha[ch & 0xff] && ch >= 0) - errfl(a->cierr, 125, where); - break; - } - Ungetc(ch,f__cf); - if (readall && !Alpha[ch & 0xff]) - goto readloop; - if ((no -= no1) <= 0) - break; - for(dn1 = dn0; dn1 <= dn; dn1++) { - if (++dn1->curval < dn1->extent) { - iva += dn1->delta; - goto readloop; - } - dn1->curval = 0; - } - break; - } - } - } - - integer -#ifdef KR_headers -s_rsne(a) cilist *a; -#else -s_rsne(cilist *a) -#endif -{ - extern int l_eof; - int n; - - f__external=1; - l_eof = 0; - if(n = c_le(a)) - return n; - if(f__curunit->uwrt && f__nowreading(f__curunit)) - err(a->cierr,errno,where0); - l_getc = t_getc; - l_ungetc = un_getc; - f__doend = xrd_SL; - n = x_rsne(a); - nml_read = 0; - if (n) - return n; - return e_rsle(); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/s_cat.c b/ext/f2c_libs/s_cat.c deleted file mode 100644 index 5bf8a628a..000000000 --- a/ext/f2c_libs/s_cat.c +++ /dev/null @@ -1,86 +0,0 @@ -/* Unless compiled with -DNO_OVERWRITE, this variant of s_cat allows the - * target of a concatenation to appear on its right-hand side (contrary - * to the Fortran 77 Standard, but in accordance with Fortran 90). - */ - -#include "f2c.h" -#ifndef NO_OVERWRITE -#include "stdio.h" -#undef abs -#ifdef KR_headers - extern char *F77_aloc(); - extern void free(); - extern void exit_(); -#else -#undef min -#undef max -#include "stdlib.h" -extern -#ifdef __cplusplus - "C" -#endif - char *F77_aloc(ftnlen, char*); -#endif -#include "string.h" -#endif /* NO_OVERWRITE */ - -#ifdef __cplusplus -extern "C" { -#endif - - VOID -#ifdef KR_headers -s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnint rnp[], *np; ftnlen ll; -#else -s_cat(char *lp, char *rpp[], ftnint rnp[], ftnint *np, ftnlen ll) -#endif -{ - ftnlen i, nc; - char *rp; - ftnlen n = *np; -#ifndef NO_OVERWRITE - ftnlen L, m; - char *lp0, *lp1; - - lp0 = 0; - lp1 = lp; - L = ll; - i = 0; - while(i < n) { - rp = rpp[i]; - m = rnp[i++]; - if (rp >= lp1 || rp + m <= lp) { - if ((L -= m) <= 0) { - n = i; - break; - } - lp1 += m; - continue; - } - lp0 = lp; - lp = lp1 = F77_aloc(L = ll, "s_cat"); - break; - } - lp1 = lp; -#endif /* NO_OVERWRITE */ - for(i = 0 ; i < n ; ++i) { - nc = ll; - if(rnp[i] < nc) - nc = rnp[i]; - ll -= nc; - rp = rpp[i]; - while(--nc >= 0) - *lp++ = *rp++; - } - while(--ll >= 0) - *lp++ = ' '; -#ifndef NO_OVERWRITE - if (lp0) { - memcpy(lp0, lp1, L); - free(lp1); - } -#endif - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/s_cmp.c b/ext/f2c_libs/s_cmp.c deleted file mode 100644 index 3a2ea67dd..000000000 --- a/ext/f2c_libs/s_cmp.c +++ /dev/null @@ -1,50 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -/* compare two strings */ - -#ifdef KR_headers -integer s_cmp(a0, b0, la, lb) char *a0, *b0; ftnlen la, lb; -#else -integer s_cmp(char *a0, char *b0, ftnlen la, ftnlen lb) -#endif -{ -register unsigned char *a, *aend, *b, *bend; -a = (unsigned char *)a0; -b = (unsigned char *)b0; -aend = a + la; -bend = b + lb; - -if(la <= lb) - { - while(a < aend) - if(*a != *b) - return( *a - *b ); - else - { ++a; ++b; } - - while(b < bend) - if(*b != ' ') - return( ' ' - *b ); - else ++b; - } - -else - { - while(b < bend) - if(*a == *b) - { ++a; ++b; } - else - return( *a - *b ); - while(a < aend) - if(*a != ' ') - return(*a - ' '); - else ++a; - } -return(0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/s_copy.c b/ext/f2c_libs/s_copy.c deleted file mode 100644 index 9dacfc7d8..000000000 --- a/ext/f2c_libs/s_copy.c +++ /dev/null @@ -1,57 +0,0 @@ -/* Unless compiled with -DNO_OVERWRITE, this variant of s_copy allows the - * target of an assignment to appear on its right-hand side (contrary - * to the Fortran 77 Standard, but in accordance with Fortran 90), - * as in a(2:5) = a(4:7) . - */ - -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -/* assign strings: a = b */ - -#ifdef KR_headers -VOID s_copy(a, b, la, lb) register char *a, *b; ftnlen la, lb; -#else -void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb) -#endif -{ - register char *aend, *bend; - - aend = a + la; - - if(la <= lb) -#ifndef NO_OVERWRITE - if (a <= b || a >= b + la) -#endif - while(a < aend) - *a++ = *b++; -#ifndef NO_OVERWRITE - else - for(b += la; a < aend; ) - *--aend = *--b; -#endif - - else { - bend = b + lb; -#ifndef NO_OVERWRITE - if (a <= b || a >= bend) -#endif - while(b < bend) - *a++ = *b++; -#ifndef NO_OVERWRITE - else { - a += lb; - while(b < bend) - *--a = *--bend; - a += lb; - } -#endif - while(a < aend) - *a++ = ' '; - } - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/s_rnge.c b/ext/f2c_libs/s_rnge.c deleted file mode 100644 index 5c12b9496..000000000 --- a/ext/f2c_libs/s_rnge.c +++ /dev/null @@ -1,32 +0,0 @@ -#include "stdio.h" -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -/* called when a subscript is out of range */ - -#ifdef KR_headers -extern VOID sig_die(); -integer s_rnge(varn, offset, procn, line) char *varn, *procn; ftnint offset, line; -#else -extern VOID sig_die(char*,int); -integer s_rnge(char *varn, ftnint offset, char *procn, ftnint line) -#endif -{ -register int i; - -fprintf(stderr, "Subscript out of range on file line %ld, procedure ", - (long)line); -while((i = *procn) && i != '_' && i != ' ') - putc(*procn++, stderr); -fprintf(stderr, ".\nAttempt to access the %ld-th element of variable ", - (long)offset+1); -while((i = *varn) && i != ' ') - putc(*varn++, stderr); -sig_die(".", 1); -return 0; /* not reached */ -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/s_stop.c b/ext/f2c_libs/s_stop.c deleted file mode 100644 index 68233aea7..000000000 --- a/ext/f2c_libs/s_stop.c +++ /dev/null @@ -1,48 +0,0 @@ -#include "stdio.h" -#include "f2c.h" - -#ifdef KR_headers -extern void f_exit(); -int s_stop(s, n) char *s; ftnlen n; -#else -#undef abs -#undef min -#undef max -#include "stdlib.h" -#ifdef __cplusplus -extern "C" { -#endif -#ifdef __cplusplus -extern "C" { -#endif -void f_exit(void); - -int s_stop(char *s, ftnlen n) -#endif -{ -int i; - -if(n > 0) - { - fprintf(stderr, "STOP "); - for(i = 0; iciunit]; - if(a->ciunit >= MXUNIT || a->ciunit<0) - err(a->cierr,101,"startio"); - if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe") - if(!p->ufmt) err(a->cierr,102,"sfe") - return(0); -} -integer e_wsfe(Void) -{ - int n = en_fio(); - f__fmtbuf = NULL; -#ifdef ALWAYS_FLUSH - if (!n && fflush(f__cf)) - err(f__elist->cierr, errno, "write end"); -#endif - return n; -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/sig_die.c b/ext/f2c_libs/sig_die.c deleted file mode 100644 index 8c22cd581..000000000 --- a/ext/f2c_libs/sig_die.c +++ /dev/null @@ -1,51 +0,0 @@ -#include "stdio.h" -#include "signal.h" - -#ifndef SIGIOT -#ifdef SIGABRT -#define SIGIOT SIGABRT -#endif -#endif - -#ifdef KR_headers -void sig_die(s, kill) register char *s; int kill; -#else -#include "stdlib.h" -#ifdef __cplusplus -extern "C" { -#endif -#ifdef __cplusplus -extern "C" { -#endif - extern void f_exit(void); - -void sig_die(register char *s, int kill) -#endif -{ - /* print error message, then clear buffers */ - fprintf(stderr, "%s\n", s); - - if(kill) - { - fflush(stderr); - f_exit(); - fflush(stderr); - /* now get a core */ -#ifdef SIGIOT - signal(SIGIOT, SIG_DFL); -#endif - abort(); - } - else { -#ifdef NO_ONEXIT - f_exit(); -#endif - exit(1); - } - } -#ifdef __cplusplus -} -#endif -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/signal1.h b/ext/f2c_libs/signal1.h deleted file mode 100644 index a383774b8..000000000 --- a/ext/f2c_libs/signal1.h +++ /dev/null @@ -1,35 +0,0 @@ -/* You may need to adjust the definition of signal1 to supply a */ -/* cast to the correct argument type. This detail is system- and */ -/* compiler-dependent. The #define below assumes signal.h declares */ -/* type SIG_PF for the signal function's second argument. */ - -/* For some C++ compilers, "#define Sigarg_t ..." may be appropriate. */ - -#include - -#ifndef Sigret_t -#define Sigret_t void -#endif -#ifndef Sigarg_t -#ifdef KR_headers -#define Sigarg_t -#else -#define Sigarg_t int -#endif -#endif /*Sigarg_t*/ - -#ifdef USE_SIG_PF /* compile with -DUSE_SIG_PF under IRIX */ -#define sig_pf SIG_PF -#else -typedef Sigret_t (*sig_pf)(Sigarg_t); -#endif - -#define signal1(a,b) signal(a,(sig_pf)b) - -#ifdef __cplusplus -#define Sigarg ... -#define Use_Sigarg -#else -#define Sigarg Int n -#define Use_Sigarg n = n /* shut up compiler warning */ -#endif diff --git a/ext/f2c_libs/signal_.c b/ext/f2c_libs/signal_.c deleted file mode 100644 index 3b0e6cfe9..000000000 --- a/ext/f2c_libs/signal_.c +++ /dev/null @@ -1,21 +0,0 @@ -#include "f2c.h" -#include "signal1.h" -#ifdef __cplusplus -extern "C" { -#endif - - ftnint -#ifdef KR_headers -signal_(sigp, proc) integer *sigp; sig_pf proc; -#else -signal_(integer *sigp, sig_pf proc) -#endif -{ - int sig; - sig = (int)*sigp; - - return (ftnint)signal(sig, proc); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/signbit.c b/ext/f2c_libs/signbit.c deleted file mode 100644 index de95a3b70..000000000 --- a/ext/f2c_libs/signbit.c +++ /dev/null @@ -1,24 +0,0 @@ -#include "arith.h" - -#ifndef Long -#define Long long -#endif - - int -#ifdef KR_headers -signbit_f2c(x) double *x; -#else -signbit_f2c(double *x) -#endif -{ -#ifdef IEEE_MC68k - if (*(Long*)x & 0x80000000) - return 1; -#else -#ifdef IEEE_8087 - if (((Long*)x)[1] & 0x80000000) - return 1; -#endif /*IEEE_8087*/ -#endif /*IEEE_MC68k*/ - return 0; - } diff --git a/ext/f2c_libs/sue.c b/ext/f2c_libs/sue.c deleted file mode 100644 index 191e32627..000000000 --- a/ext/f2c_libs/sue.c +++ /dev/null @@ -1,90 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#ifdef __cplusplus -extern "C" { -#endif -extern uiolen f__reclen; -OFF_T f__recloc; - - int -#ifdef KR_headers -c_sue(a) cilist *a; -#else -c_sue(cilist *a) -#endif -{ - f__external=f__sequential=1; - f__formatted=0; - f__curunit = &f__units[a->ciunit]; - if(a->ciunit >= MXUNIT || a->ciunit < 0) - err(a->cierr,101,"startio"); - f__elist=a; - if(f__curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit)) - err(a->cierr,114,"sue"); - f__cf=f__curunit->ufd; - if(f__curunit->ufmt) err(a->cierr,103,"sue") - if(!f__curunit->useek) err(a->cierr,103,"sue") - return(0); -} -#ifdef KR_headers -integer s_rsue(a) cilist *a; -#else -integer s_rsue(cilist *a) -#endif -{ - int n; - if(!f__init) f_init(); - f__reading=1; - if(n=c_sue(a)) return(n); - f__recpos=0; - if(f__curunit->uwrt && f__nowreading(f__curunit)) - err(a->cierr, errno, "read start"); - if(fread((char *)&f__reclen,sizeof(uiolen),1,f__cf) - != 1) - { if(feof(f__cf)) - { f__curunit->uend = 1; - err(a->ciend, EOF, "start"); - } - clearerr(f__cf); - err(a->cierr, errno, "start"); - } - return(0); -} -#ifdef KR_headers -integer s_wsue(a) cilist *a; -#else -integer s_wsue(cilist *a) -#endif -{ - int n; - if(!f__init) f_init(); - if(n=c_sue(a)) return(n); - f__reading=0; - f__reclen=0; - if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) - err(a->cierr, errno, "write start"); - f__recloc=FTELL(f__cf); - FSEEK(f__cf,(OFF_T)sizeof(uiolen),SEEK_CUR); - return(0); -} -integer e_wsue(Void) -{ OFF_T loc; - fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); -#ifdef ALWAYS_FLUSH - if (fflush(f__cf)) - err(f__elist->cierr, errno, "write end"); -#endif - loc=FTELL(f__cf); - FSEEK(f__cf,f__recloc,SEEK_SET); - fwrite((char *)&f__reclen,sizeof(uiolen),1,f__cf); - FSEEK(f__cf,loc,SEEK_SET); - return(0); -} -integer e_rsue(Void) -{ - FSEEK(f__cf,(OFF_T)(f__reclen-f__recpos+sizeof(uiolen)),SEEK_CUR); - return(0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/sysdep1.h b/ext/f2c_libs/sysdep1.h deleted file mode 100644 index 259b2b020..000000000 --- a/ext/f2c_libs/sysdep1.h +++ /dev/null @@ -1,78 +0,0 @@ -#ifndef SYSDEP_H_INCLUDED -#define SYSDEP_H_INCLUDED -#undef USE_LARGEFILE -#ifndef NO_LONG_LONG - -#ifdef __sun__ -#define USE_LARGEFILE -#define OFF_T off64_t -// On some older solaris systems, it seems that OFF_T needed to -// be set to an int sometimes. It didn't cause crashes if you -// didn't. However, ld warnings would occur if the sys -lg2c -// libs were loaded at the same time. -// see man pages for fseek and fseeko. -// Can be debugged by finding out what off_t is set to in the -// the standard compiler headings. -//#define OFF_T int -#endif - -#ifdef __linux__ -#define USE_LARGEFILE -#define OFF_T __off64_t -#endif - -#ifdef _AIX43 -#define _LARGE_FILES -#define _LARGE_FILE_API -#define USE_LARGEFILE -#endif /*_AIX43*/ - -#ifdef __hpux -#define _FILE64 -#define _LARGEFILE64_SOURCE -#define USE_LARGEFILE -#endif /*__hpux*/ - -#ifdef __sgi -#define USE_LARGEFILE -#endif /*__sgi*/ - -#ifdef __FreeBSD__ -#define OFF_T off_t -#define FSEEK fseeko -#define FTELL ftello -#endif - -#ifdef USE_LARGEFILE -#ifndef OFF_T -#define OFF_T off64_t -#endif -#ifndef _LARGEFILE_SOURCE -#define _LARGEFILE_SOURCE -#endif -#ifndef _LARGEFILE64_SOURCE -#define _LARGEFILE64_SOURCE -#endif -#include -#include -#define FOPEN fopen64 -#define FREOPEN freopen64 -#define FSEEK fseeko64 -#define FSTAT fstat64 -#define FTELL ftello64 -#define FTRUNCATE ftruncate64 -#define STAT stat64 -#define STAT_ST stat64 -#endif /*USE_LARGEFILE*/ -#endif /*NO_LONG_LONG*/ - -#ifndef NON_UNIX_STDIO -#ifndef USE_LARGEFILE -#define _INCLUDE_POSIX_SOURCE /* for HP-UX */ -#define _INCLUDE_XOPEN_SOURCE /* for HP-UX */ -#include "sys/types.h" -#include "sys/stat.h" -#endif -#endif - -#endif /*SYSDEP_H_INCLUDED*/ diff --git a/ext/f2c_libs/system_.c b/ext/f2c_libs/system_.c deleted file mode 100644 index 3220bfb5c..000000000 --- a/ext/f2c_libs/system_.c +++ /dev/null @@ -1,42 +0,0 @@ -/* f77 interface to system routine */ - -#include "f2c.h" - -#ifdef KR_headers -extern char *F77_aloc(); - - integer -system_(s, n) register char *s; ftnlen n; -#else -#undef abs -#undef min -#undef max -#include "stdlib.h" -#ifdef __cplusplus -extern "C" { -#endif -extern char *F77_aloc(ftnlen, char*); - - integer -system_(register char *s, ftnlen n) -#endif -{ - char buff0[256], *buff; - register char *bp, *blast; - integer rv; - - buff = bp = n < sizeof(buff0) - ? buff0 : F77_aloc(n+1, "system_"); - blast = bp + n; - - while(bp < blast && *s) - *bp++ = *s++; - *bp = 0; - rv = system(buff); - if (buff != buff0) - free(buff); - return rv; - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/typesize.c b/ext/f2c_libs/typesize.c deleted file mode 100644 index 39097f469..000000000 --- a/ext/f2c_libs/typesize.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -ftnlen f__typesize[] = { 0, 0, sizeof(shortint), sizeof(integer), - sizeof(real), sizeof(doublereal), - sizeof(complex), sizeof(doublecomplex), - sizeof(logical), sizeof(char), - 0, sizeof(integer1), - sizeof(logical1), sizeof(shortlogical), -#ifdef Allow_TYQUAD - sizeof(longint), -#endif - 0}; -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/uio.c b/ext/f2c_libs/uio.c deleted file mode 100644 index 44f768d9a..000000000 --- a/ext/f2c_libs/uio.c +++ /dev/null @@ -1,75 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#ifdef __cplusplus -extern "C" { -#endif -uiolen f__reclen; - - int -#ifdef KR_headers -do_us(number,ptr,len) ftnint *number; char *ptr; ftnlen len; -#else -do_us(ftnint *number, char *ptr, ftnlen len) -#endif -{ - if(f__reading) - { - f__recpos += (int)(*number * len); - if(f__recpos>f__reclen) - err(f__elist->cierr, 110, "do_us"); - if (fread(ptr,(int)len,(int)(*number),f__cf) != *number) - err(f__elist->ciend, EOF, "do_us"); - return(0); - } - else - { - f__reclen += *number * len; - (void) fwrite(ptr,(int)len,(int)(*number),f__cf); - return(0); - } -} -#ifdef KR_headers -integer do_ud(number,ptr,len) ftnint *number; char *ptr; ftnlen len; -#else -integer do_ud(ftnint *number, char *ptr, ftnlen len) -#endif -{ - f__recpos += (int)(*number * len); - if(f__recpos > f__curunit->url && f__curunit->url!=1) - err(f__elist->cierr,110,"do_ud"); - if(f__reading) - { -#ifdef Pad_UDread -#ifdef KR_headers - int i; -#else - size_t i; -#endif - if (!(i = fread(ptr,(int)len,(int)(*number),f__cf)) - && !(f__recpos - *number*len)) - err(f__elist->cierr,EOF,"do_ud") - if (i < *number) - memset(ptr + i*len, 0, (*number - i)*len); - return 0; -#else - if(fread(ptr,(int)len,(int)(*number),f__cf) != *number) - err(f__elist->cierr,EOF,"do_ud") - else return(0); -#endif - } - (void) fwrite(ptr,(int)len,(int)(*number),f__cf); - return(0); -} -#ifdef KR_headers -integer do_uio(number,ptr,len) ftnint *number; char *ptr; ftnlen len; -#else -integer do_uio(ftnint *number, char *ptr, ftnlen len) -#endif -{ - if(f__sequential) - return(do_us(number,ptr,len)); - else return(do_ud(number,ptr,len)); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/uninit.c b/ext/f2c_libs/uninit.c deleted file mode 100644 index 794cd6ade..000000000 --- a/ext/f2c_libs/uninit.c +++ /dev/null @@ -1,368 +0,0 @@ -#include -#include -#include "arith.h" - -#define TYSHORT 2 -#define TYLONG 3 -#define TYREAL 4 -#define TYDREAL 5 -#define TYCOMPLEX 6 -#define TYDCOMPLEX 7 -#define TYINT1 11 -#define TYQUAD 14 -#ifndef Long -#define Long long -#endif - -#ifdef __mips -#define RNAN 0xffc00000 -#define DNAN0 0xfff80000 -#define DNAN1 0 -#endif - -#ifdef _PA_RISC1_1 -#define RNAN 0xffc00000 -#define DNAN0 0xfff80000 -#define DNAN1 0 -#endif - -#ifndef RNAN -#define RNAN 0xff800001 -#ifdef IEEE_MC68k -#define DNAN0 0xfff00000 -#define DNAN1 1 -#else -#define DNAN0 1 -#define DNAN1 0xfff00000 -#endif -#endif /*RNAN*/ - -#ifdef KR_headers -#define Void /*void*/ -#define FA7UL (unsigned Long) 0xfa7a7a7aL -#else -#define Void void -#define FA7UL 0xfa7a7a7aUL -#endif - -#ifdef __cplusplus -extern "C" { -#endif - -static void ieee0(Void); - -static unsigned Long rnan = RNAN, - dnan0 = DNAN0, - dnan1 = DNAN1; - -double _0 = 0.; - - void -#ifdef KR_headers -_uninit_f2c(x, type, len) void *x; int type; long len; -#else -_uninit_f2c(void *x, int type, long len) -#endif -{ - static int first = 1; - - unsigned Long *lx, *lxe; - - if (first) { - first = 0; - ieee0(); - } - if (len == 1) - switch(type) { - case TYINT1: - *(char*)x = 'Z'; - return; - case TYSHORT: - *(short*)x = 0xfa7a; - break; - case TYLONG: - *(unsigned Long*)x = FA7UL; - return; - case TYQUAD: - case TYCOMPLEX: - case TYDCOMPLEX: - break; - case TYREAL: - *(unsigned Long*)x = rnan; - return; - case TYDREAL: - lx = (unsigned Long*)x; - lx[0] = dnan0; - lx[1] = dnan1; - return; - default: - printf("Surprise type %d in _uninit_f2c\n", type); - } - switch(type) { - case TYINT1: - memset(x, 'Z', len); - break; - case TYSHORT: - *(short*)x = 0xfa7a; - break; - case TYQUAD: - len *= 2; - /* no break */ - case TYLONG: - lx = (unsigned Long*)x; - lxe = lx + len; - while(lx < lxe) - *lx++ = FA7UL; - break; - case TYCOMPLEX: - len *= 2; - /* no break */ - case TYREAL: - lx = (unsigned Long*)x; - lxe = lx + len; - while(lx < lxe) - *lx++ = rnan; - break; - case TYDCOMPLEX: - len *= 2; - /* no break */ - case TYDREAL: - lx = (unsigned Long*)x; - for(lxe = lx + 2*len; lx < lxe; lx += 2) { - lx[0] = dnan0; - lx[1] = dnan1; - } - } - } -#ifdef __cplusplus -} -#endif - -#ifndef MSpc -#ifdef MSDOS -#define MSpc -#else -#ifdef _WIN32 -#define MSpc -#endif -#endif -#endif - -#ifdef MSpc -#define IEEE0_done -#include "float.h" -#include "signal.h" - - static void -ieee0(Void) -{ -#ifndef __alpha -#ifndef EM_DENORMAL -#define EM_DENORMAL _EM_DENORMAL -#endif -#ifndef EM_UNDERFLOW -#define EM_UNDERFLOW _EM_UNDERFLOW -#endif -#ifndef EM_INEXACT -#define EM_INEXACT _EM_INEXACT -#endif -#ifndef MCW_EM -#define MCW_EM _MCW_EM -#endif - _control87(EM_DENORMAL | EM_UNDERFLOW | EM_INEXACT, MCW_EM); -#endif - /* With MS VC++, compiling and linking with -Zi will permit */ - /* clicking to invoke the MS C++ debugger, which will show */ - /* the point of error -- provided SIGFPE is SIG_DFL. */ - signal(SIGFPE, SIG_DFL); - } -#endif /* MSpc */ - -#ifdef __mips /* must link with -lfpe */ -#define IEEE0_done -/* code from Eric Grosse */ -#include -#include -#include "/usr/include/sigfpe.h" /* full pathname for lcc -N */ -#include "/usr/include/sys/fpu.h" - - static void -#ifdef KR_headers -ieeeuserhand(exception, val) unsigned exception[5]; int val[2]; -#else -ieeeuserhand(unsigned exception[5], int val[2]) -#endif -{ - fflush(stdout); - fprintf(stderr,"ieee0() aborting because of "); - if(exception[0]==_OVERFL) fprintf(stderr,"overflow\n"); - else if(exception[0]==_UNDERFL) fprintf(stderr,"underflow\n"); - else if(exception[0]==_DIVZERO) fprintf(stderr,"divide by 0\n"); - else if(exception[0]==_INVALID) fprintf(stderr,"invalid operation\n"); - else fprintf(stderr,"\tunknown reason\n"); - fflush(stderr); - abort(); -} - - static void -#ifdef KR_headers -ieeeuserhand2(j) unsigned int **j; -#else -ieeeuserhand2(unsigned int **j) -#endif -{ - fprintf(stderr,"ieee0() aborting because of confusion\n"); - abort(); -} - - static void -ieee0(Void) -{ - int i; - for(i=1; i<=4; i++){ - sigfpe_[i].count = 1000; - sigfpe_[i].trace = 1; - sigfpe_[i].repls = _USER_DETERMINED; - } - sigfpe_[1].repls = _ZERO; /* underflow */ - handle_sigfpes( _ON, - _EN_UNDERFL|_EN_OVERFL|_EN_DIVZERO|_EN_INVALID, - ieeeuserhand,_ABORT_ON_ERROR,ieeeuserhand2); - } -#endif /* mips */ - -#ifdef __linux__ -#define IEEE0_done -#include "fpu_control.h" - -#ifdef __alpha__ -#ifndef USE_setfpucw -#define __setfpucw(x) __fpu_control = (x) -#endif -#endif - -#ifndef _FPU_SETCW -#undef Can_use__setfpucw -#define Can_use__setfpucw -#endif - - static void -ieee0(Void) -{ -#if (defined(__mc68000__) || defined(__mc68020__) || defined(mc68020) || defined (__mc68k__)) -/* Reported 20010705 by Alan Bain */ -/* Note that IEEE 754 IOP (illegal operation) */ -/* = Signaling NAN (SNAN) + operation error (OPERR). */ -#ifdef Can_use__setfpucw /* Has __setfpucw gone missing from S.u.S.E. 6.3? */ - __setfpucw(_FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL); -#else - __fpu_control = _FPU_IEEE + _FPU_DOUBLE + _FPU_MASK_OPERR + _FPU_MASK_DZ + _FPU_MASK_SNAN+_FPU_MASK_OVFL; - _FPU_SETCW(__fpu_control); -#endif - -#elif (defined(__powerpc__)||defined(_ARCH_PPC)||defined(_ARCH_PWR)) /* !__mc68k__ */ -/* Reported 20011109 by Alan Bain */ - -#ifdef Can_use__setfpucw - -/* The following is NOT a mistake -- the author of the fpu_control.h -for the PPC has erroneously defined IEEE mode to turn on exceptions -other than Inexact! Start from default then and turn on only the ones -which we want*/ - - __setfpucw(_FPU_DEFAULT + _FPU_MASK_IM+_FPU_MASK_OM+_FPU_MASK_UM); - -#else /* PPC && !Can_use__setfpucw */ - - __fpu_control = _FPU_DEFAULT +_FPU_MASK_OM+_FPU_MASK_IM+_FPU_MASK_UM; - _FPU_SETCW(__fpu_control); - -#endif /*Can_use__setfpucw*/ - -#else /* !(mc68000||powerpc) */ - -#ifdef _FPU_IEEE -#ifndef _FPU_EXTENDED /* e.g., ARM processor under Linux */ -#define _FPU_EXTENDED 0 -#endif -#ifndef _FPU_DOUBLE -#define _FPU_DOUBLE 0 -#endif -#ifdef Can_use__setfpucw /* Has __setfpucw gone missing from S.u.S.E. 6.3? */ - __setfpucw(_FPU_IEEE - _FPU_EXTENDED + _FPU_DOUBLE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM); -#else - __fpu_control = _FPU_IEEE - _FPU_EXTENDED + _FPU_DOUBLE - _FPU_MASK_IM - _FPU_MASK_ZM - _FPU_MASK_OM; - _FPU_SETCW(__fpu_control); -#endif - -#else /* !_FPU_IEEE */ - - fprintf(stderr, "\n%s\n%s\n%s\n%s\n", - "WARNING: _uninit_f2c in libf2c does not know how", - "to enable trapping on this system, so f2c's -trapuv", - "option will not detect uninitialized variables unless", - "you can enable trapping manually."); - fflush(stderr); - -#endif /* _FPU_IEEE */ -#endif /* __mc68k__ */ - } -#endif /* __linux__ */ - -#ifdef __alpha -#ifndef IEEE0_done -#define IEEE0_done -#include - static void -ieee0(Void) -{ - ieee_set_fp_control(IEEE_TRAP_ENABLE_INV); - } -#endif /*IEEE0_done*/ -#endif /*__alpha*/ - -#ifdef __hpux -#define IEEE0_done -#define _INCLUDE_HPUX_SOURCE -#include - -#ifndef FP_X_INV -#include -#define fpsetmask fesettrapenable -#define FP_X_INV FE_INVALID -#endif - - static void -ieee0(Void) -{ - fpsetmask(FP_X_INV); - } -#endif /*__hpux*/ - -#ifdef _AIX -#define IEEE0_done -#include - - static void -ieee0(Void) -{ - fp_enable(TRP_INVALID); - fp_trap(FP_TRAP_SYNC); - } -#endif /*_AIX*/ - -#ifdef __sun -#define IEEE0_done -#include - - static void -ieee0(Void) -{ - fpsetmask(FP_X_INV); - } -#endif /*__sparc*/ - -#ifndef IEEE0_done - static void -ieee0(Void) {} -#endif diff --git a/ext/f2c_libs/util.c b/ext/f2c_libs/util.c deleted file mode 100644 index 09009816b..000000000 --- a/ext/f2c_libs/util.c +++ /dev/null @@ -1,69 +0,0 @@ -#include "sysdep1.h" /* here to get stat64 on some badly designed Linux systems */ -#include "f2c.h" -#include "fio.h" -#ifndef KR_headers -#undef abs -#undef min -#undef max -#include -#endif - -#ifndef NON_POSIX_STDIO -#ifdef MSDOS -#include "io.h" -#else -#include "unistd.h" /* for access */ -#endif -#endif - -#ifdef __cplusplus -extern "C" { -#endif - - VOID -#ifdef KR_headers -g_char(a,alen,b) char *a,*b; ftnlen alen; -#else -g_char(char *a, ftnlen alen, char *b) -#endif -{ - char *x = a + alen, *y = b + alen; - - for(;; y--) { - if (x <= a) { - *b = 0; - return; - } - if (*--x != ' ') - break; - } - *y-- = 0; - do *y-- = *x; - while(x-- > a); - } - - VOID -#ifdef KR_headers -b_char(a,b,blen) char *a,*b; ftnlen blen; -#else -b_char(char *a, char *b, ftnlen blen) -#endif -{ int i; - for(i=0;i= d + 2 || f__scale <= -d) - goto nogood; - } - if(f__scale <= 0) - --d; - if (len == sizeof(real)) - dd = p->pf; - else - dd = p->pd; - if (dd < 0.) { - signspace = sign = 1; - dd = -dd; - } - else { - sign = 0; - signspace = (int)f__cplus; -#ifndef VAX - if (!dd) { -#ifdef SIGNED_ZEROS - if (signbit_f2c(&dd)) - signspace = sign = 1; -#endif - dd = 0.; /* avoid -0 */ - } -#endif - } - delta = w - (2 /* for the . and the d adjustment above */ - + 2 /* for the E+ */ + signspace + d + e); -#ifdef WANT_LEAD_0 - if (f__scale <= 0 && delta > 0) { - delta--; - insert0 = 1; - } - else -#endif - if (delta < 0) { -nogood: - while(--w >= 0) - PUT('*'); - return(0); - } - if (f__scale < 0) - d += f__scale; - if (d > FMAX) { - d1 = d - FMAX; - d = FMAX; - } - else - d1 = 0; - sprintf(buf,"%#.*E", d, dd); -#ifndef VAX - /* check for NaN, Infinity */ - if (!isdigit(buf[0])) { - switch(buf[0]) { - case 'n': - case 'N': - signspace = 0; /* no sign for NaNs */ - } - delta = w - (int) strlen(buf) - signspace; - if (delta < 0) - goto nogood; - while(--delta >= 0) - PUT(' '); - if (signspace) - PUT(sign ? '-' : '+'); - for(s = buf; *s; s++) - PUT(*s); - return 0; - } -#endif - se = buf + d + 3; -#ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */ - if (f__scale != 1 && dd) - sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); -#else - if (dd) - sprintf(se, "%+.2d", atoi(se) + 1 - f__scale); - else - strcpy(se, "+00"); -#endif - s = ++se; - if (e < 2) { - if (*s != '0') - goto nogood; - } -#ifndef VAX - /* accommodate 3 significant digits in exponent */ - if (s[2]) { -#ifdef Pedantic - if (!e0 && !s[3]) - for(s -= 2, e1 = 2; s[0] = s[1]; s++); - - /* Pedantic gives the behavior that Fortran 77 specifies, */ - /* i.e., requires that E be specified for exponent fields */ - /* of more than 3 digits. With Pedantic undefined, we get */ - /* the behavior that Cray displays -- you get a bigger */ - /* exponent field if it fits. */ -#else - if (!e0) { - for(s -= 2, e1 = 2; s[0] = s[1]; s++) -#ifdef CRAY - delta--; - if ((delta += 4) < 0) - goto nogood -#endif - ; - } -#endif - else if (e0 >= 0) - goto shift; - else - e1 = e; - } - else - shift: -#endif - for(s += 2, e1 = 2; *s; ++e1, ++s) - if (e1 >= e) - goto nogood; - while(--delta >= 0) - PUT(' '); - if (signspace) - PUT(sign ? '-' : '+'); - s = buf; - i = f__scale; - if (f__scale <= 0) { -#ifdef WANT_LEAD_0 - if (insert0) - PUT('0'); -#endif - PUT('.'); - for(; i < 0; ++i) - PUT('0'); - PUT(*s); - s += 2; - } - else if (f__scale > 1) { - PUT(*s); - s += 2; - while(--i > 0) - PUT(*s++); - PUT('.'); - } - if (d1) { - se -= 2; - while(s < se) PUT(*s++); - se += 2; - do PUT('0'); while(--d1 > 0); - } - while(s < se) - PUT(*s++); - if (e < 2) - PUT(s[1]); - else { - while(++e1 <= e) - PUT('0'); - while(*s) - PUT(*s++); - } - return 0; - } - - int -#ifdef KR_headers -wrt_F(p,w,d,len) ufloat *p; ftnlen len; -#else -wrt_F(ufloat *p, int w, int d, ftnlen len) -#endif -{ - int d1, sign, n; - double x; - char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s; - - x= (len==sizeof(real)?p->pf:p->pd); - if (d < MAXFRACDIGS) - d1 = 0; - else { - d1 = d - MAXFRACDIGS; - d = MAXFRACDIGS; - } - if (x < 0.) - { x = -x; sign = 1; } - else { - sign = 0; -#ifndef VAX - if (!x) { -#ifdef SIGNED_ZEROS - if (signbit_f2c(&x)) - sign = 2; -#endif - x = 0.; - } -#endif - } - - if (n = f__scale) - if (n > 0) - do x *= 10.; while(--n > 0); - else - do x *= 0.1; while(++n < 0); - -#ifdef USE_STRLEN - sprintf(b = buf, "%#.*f", d, x); - n = strlen(b) + d1; -#else - n = sprintf(b = buf, "%#.*f", d, x) + d1; -#endif - -#ifndef WANT_LEAD_0 - if (buf[0] == '0' && d) - { ++b; --n; } -#endif - if (sign == 1) { - /* check for all zeros */ - for(s = b;;) { - while(*s == '0') s++; - switch(*s) { - case '.': - s++; continue; - case 0: - sign = 0; - } - break; - } - } - if (sign || f__cplus) - ++n; - if (n > w) { -#ifdef WANT_LEAD_0 - if (buf[0] == '0' && --n == w) - ++b; - else -#endif - { - while(--w >= 0) - PUT('*'); - return 0; - } - } - for(w -= n; --w >= 0; ) - PUT(' '); - if (sign) - PUT('-'); - else if (f__cplus) - PUT('+'); - while(n = *b++) - PUT(n); - while(--d1 >= 0) - PUT('0'); - return 0; - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/wrtfmt.c b/ext/f2c_libs/wrtfmt.c deleted file mode 100644 index 8fef6763b..000000000 --- a/ext/f2c_libs/wrtfmt.c +++ /dev/null @@ -1,377 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#include "fmt.h" -#ifdef __cplusplus -extern "C" { -#endif - -extern icilist *f__svic; -extern char *f__icptr; - - static int -mv_cur(Void) /* shouldn't use fseek because it insists on calling fflush */ - /* instead we know too much about stdio */ -{ - int cursor = f__cursor; - f__cursor = 0; - if(f__external == 0) { - if(cursor < 0) { - if(f__hiwater < f__recpos) - f__hiwater = f__recpos; - f__recpos += cursor; - f__icptr += cursor; - if(f__recpos < 0) - err(f__elist->cierr, 110, "left off"); - } - else if(cursor > 0) { - if(f__recpos + cursor >= f__svic->icirlen) - err(f__elist->cierr, 110, "recend"); - if(f__hiwater <= f__recpos) - for(; cursor > 0; cursor--) - (*f__putn)(' '); - else if(f__hiwater <= f__recpos + cursor) { - cursor -= f__hiwater - f__recpos; - f__icptr += f__hiwater - f__recpos; - f__recpos = f__hiwater; - for(; cursor > 0; cursor--) - (*f__putn)(' '); - } - else { - f__icptr += cursor; - f__recpos += cursor; - } - } - return(0); - } - if (cursor > 0) { - if(f__hiwater <= f__recpos) - for(;cursor>0;cursor--) (*f__putn)(' '); - else if(f__hiwater <= f__recpos + cursor) { - cursor -= f__hiwater - f__recpos; - f__recpos = f__hiwater; - for(; cursor > 0; cursor--) - (*f__putn)(' '); - } - else { - f__recpos += cursor; - } - } - else if (cursor < 0) - { - if(cursor + f__recpos < 0) - err(f__elist->cierr,110,"left off"); - if(f__hiwater < f__recpos) - f__hiwater = f__recpos; - f__recpos += cursor; - } - return(0); -} - - static int -#ifdef KR_headers -wrt_Z(n,w,minlen,len) Uint *n; int w, minlen; ftnlen len; -#else -wrt_Z(Uint *n, int w, int minlen, ftnlen len) -#endif -{ - register char *s, *se; - register int i, w1; - static int one = 1; - static char hex[] = "0123456789ABCDEF"; - s = (char *)n; - --len; - if (*(char *)&one) { - /* little endian */ - se = s; - s += len; - i = -1; - } - else { - se = s + len; - i = 1; - } - for(;; s += i) - if (s == se || *s) - break; - w1 = (int) (i*(se-s) << 1) + 1; - if (*s & 0xf0) - w1++; - if (w1 > w) - for(i = 0; i < w; i++) - (*f__putn)('*'); - else { - if ((minlen -= w1) > 0) - w1 += minlen; - while(--w >= w1) - (*f__putn)(' '); - while(--minlen >= 0) - (*f__putn)('0'); - if (!(*s & 0xf0)) { - (*f__putn)(hex[*s & 0xf]); - if (s == se) - return 0; - s += i; - } - for(;; s += i) { - (*f__putn)(hex[*s >> 4 & 0xf]); - (*f__putn)(hex[*s & 0xf]); - if (s == se) - break; - } - } - return 0; - } - - static int -#ifdef KR_headers -wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base; -#else -wrt_I(Uint *n, int w, ftnlen len, register int base) -#endif -{ int ndigit,sign,spare,i; - longint x; - char *ans; - if(len==sizeof(integer)) x=n->il; - else if(len == sizeof(char)) x = n->ic; -#ifdef Allow_TYQUAD - else if (len == sizeof(longint)) x = n->ili; -#endif - else x=n->is; - ans=f__icvt(x,&ndigit,&sign, base); - spare=w-ndigit; - if(sign || f__cplus) spare--; - if(spare<0) - for(i=0;iil; - else if(len == sizeof(char)) x = n->ic; -#ifdef Allow_TYQUAD - else if (len == sizeof(longint)) x = n->ili; -#endif - else x=n->is; - ans=f__icvt(x,&ndigit,&sign, base); - if(sign || f__cplus) xsign=1; - else xsign=0; - if(ndigit+xsign>w || m+xsign>w) - { for(i=0;i=m) - spare=w-ndigit-xsign; - else - spare=w-m-xsign; - for(i=0;iil; - else if(sz == sizeof(char)) x = n->ic; - else x=n->is; - for(i=0;i 0) (*f__putn)(*p++); - return(0); -} - static int -#ifdef KR_headers -wrt_AW(p,w,len) char * p; ftnlen len; -#else -wrt_AW(char * p, int w, ftnlen len) -#endif -{ - while(w>len) - { w--; - (*f__putn)(' '); - } - while(w-- > 0) - (*f__putn)(*p++); - return(0); -} - - static int -#ifdef KR_headers -wrt_G(p,w,d,e,len) ufloat *p; ftnlen len; -#else -wrt_G(ufloat *p, int w, int d, int e, ftnlen len) -#endif -{ double up = 1,x; - int i=0,oldscale,n,j; - x = len==sizeof(real)?p->pf:p->pd; - if(x < 0 ) x = -x; - if(x<.1) { - if (x != 0.) - return(wrt_E(p,w,d,e,len)); - i = 1; - goto have_i; - } - for(;i<=d;i++,up*=10) - { if(x>=up) continue; - have_i: - oldscale = f__scale; - f__scale = 0; - if(e==0) n=4; - else n=e+2; - i=wrt_F(p,w-n,d-i,len); - for(j=0;jop) - { - default: - fprintf(stderr,"w_ed, unexpected code: %d\n", p->op); - sig_die(f__fmtbuf, 1); - case I: return(wrt_I((Uint *)ptr,p->p1,len, 10)); - case IM: - return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,10)); - - /* O and OM don't work right for character, double, complex, */ - /* or doublecomplex, and they differ from Fortran 90 in */ - /* showing a minus sign for negative values. */ - - case O: return(wrt_I((Uint *)ptr, p->p1, len, 8)); - case OM: - return(wrt_IM((Uint *)ptr,p->p1,p->p2.i[0],len,8)); - case L: return(wrt_L((Uint *)ptr,p->p1, len)); - case A: return(wrt_A(ptr,len)); - case AW: - return(wrt_AW(ptr,p->p1,len)); - case D: - case E: - case EE: - return(wrt_E((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len)); - case G: - case GE: - return(wrt_G((ufloat *)ptr,p->p1,p->p2.i[0],p->p2.i[1],len)); - case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2.i[0],len)); - - /* Z and ZM assume 8-bit bytes. */ - - case Z: return(wrt_Z((Uint *)ptr,p->p1,0,len)); - case ZM: - return(wrt_Z((Uint *)ptr,p->p1,p->p2.i[0],len)); - } -} - - int -#ifdef KR_headers -w_ned(p) struct syl *p; -#else -w_ned(struct syl *p) -#endif -{ - switch(p->op) - { - default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op); - sig_die(f__fmtbuf, 1); - case SLASH: - return((*f__donewrec)()); - case T: f__cursor = p->p1-f__recpos - 1; - return(1); - case TL: f__cursor -= p->p1; - if(f__cursor < -f__recpos) /* TL1000, 1X */ - f__cursor = -f__recpos; - return(1); - case TR: - case X: - f__cursor += p->p1; - return(1); - case APOS: - return(wrt_AP(p->p2.s)); - case H: - return(wrt_H(p->p1,p->p2.s)); - } -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/wsfe.c b/ext/f2c_libs/wsfe.c deleted file mode 100644 index 8709f3b34..000000000 --- a/ext/f2c_libs/wsfe.c +++ /dev/null @@ -1,78 +0,0 @@ -/*write sequential formatted external*/ -#include "f2c.h" -#include "fio.h" -#include "fmt.h" -#ifdef __cplusplus -extern "C" { -#endif - - int -x_wSL(Void) -{ - int n = f__putbuf('\n'); - f__hiwater = f__recpos = f__cursor = 0; - return(n == 0); -} - - static int -xw_end(Void) -{ - int n; - - if(f__nonl) { - f__putbuf(n = 0); - fflush(f__cf); - } - else - n = f__putbuf('\n'); - f__hiwater = f__recpos = f__cursor = 0; - return n; -} - - static int -xw_rev(Void) -{ - int n = 0; - if(f__workdone) { - n = f__putbuf('\n'); - f__workdone = 0; - } - f__hiwater = f__recpos = f__cursor = 0; - return n; -} - -#ifdef KR_headers -integer s_wsfe(a) cilist *a; /*start*/ -#else -integer s_wsfe(cilist *a) /*start*/ -#endif -{ int n; - if(!f__init) f_init(); - f__reading=0; - f__sequential=1; - f__formatted=1; - f__external=1; - if(n=c_sfe(a)) return(n); - f__elist=a; - f__hiwater = f__cursor=f__recpos=0; - f__nonl = 0; - f__scale=0; - f__fmtbuf=a->cifmt; - f__cf=f__curunit->ufd; - if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio"); - f__putn= x_putc; - f__doed= w_ed; - f__doned= w_ned; - f__doend=xw_end; - f__dorevert=xw_rev; - f__donewrec=x_wSL; - fmt_bg(); - f__cplus=0; - f__cblank=f__curunit->ublnk; - if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) - err(a->cierr,errno,"write start"); - return(0); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/wsle.c b/ext/f2c_libs/wsle.c deleted file mode 100644 index 3e602702c..000000000 --- a/ext/f2c_libs/wsle.c +++ /dev/null @@ -1,42 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#include "fmt.h" -#include "lio.h" -#include "string.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -integer s_wsle(a) cilist *a; -#else -integer s_wsle(cilist *a) -#endif -{ - int n; - if(n=c_le(a)) return(n); - f__reading=0; - f__external=1; - f__formatted=1; - f__putn = x_putc; - f__lioproc = l_write; - L_len = LINE; - f__donewrec = x_wSL; - if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) - err(a->cierr, errno, "list output start"); - return(0); - } - -integer e_wsle(Void) -{ - int n = f__putbuf('\n'); - f__recpos=0; -#ifdef ALWAYS_FLUSH - if (!n && fflush(f__cf)) - err(f__elist->cierr, errno, "write end"); -#endif - return(n); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/wsne.c b/ext/f2c_libs/wsne.c deleted file mode 100644 index e204a51a4..000000000 --- a/ext/f2c_libs/wsne.c +++ /dev/null @@ -1,32 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#include "lio.h" -#ifdef __cplusplus -extern "C" { -#endif - - integer -#ifdef KR_headers -s_wsne(a) cilist *a; -#else -s_wsne(cilist *a) -#endif -{ - int n; - - if(n=c_le(a)) - return(n); - f__reading=0; - f__external=1; - f__formatted=1; - f__putn = x_putc; - L_len = LINE; - f__donewrec = x_wSL; - if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit)) - err(a->cierr, errno, "namelist output start"); - x_wsne(a); - return e_wsle(); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/xwsne.c b/ext/f2c_libs/xwsne.c deleted file mode 100644 index f810d3edb..000000000 --- a/ext/f2c_libs/xwsne.c +++ /dev/null @@ -1,77 +0,0 @@ -#include "f2c.h" -#include "fio.h" -#include "lio.h" -#include "fmt.h" - -extern int f__Aquote; - - static VOID -nl_donewrec(Void) -{ - (*f__donewrec)(); - PUT(' '); - } - -#ifdef KR_headers -x_wsne(a) cilist *a; -#else -#include "string.h" -#ifdef __cplusplus -extern "C" { -#endif - - VOID -x_wsne(cilist *a) -#endif -{ - Namelist *nl; - char *s; - Vardesc *v, **vd, **vde; - ftnint number, type; - ftnlen *dims; - ftnlen size; - extern ftnlen f__typesize[]; - - nl = (Namelist *)a->cifmt; - PUT('&'); - for(s = nl->name; *s; s++) - PUT(*s); - PUT(' '); - f__Aquote = 1; - vd = nl->vars; - vde = vd + nl->nvars; - while(vd < vde) { - v = *vd++; - s = v->name; -#ifdef No_Extra_Namelist_Newlines - if (f__recpos+strlen(s)+2 >= L_len) -#endif - nl_donewrec(); - while(*s) - PUT(*s++); - PUT(' '); - PUT('='); - number = (dims = v->dims) ? dims[1] : 1; - type = v->type; - if (type < 0) { - size = -type; - type = TYCHAR; - } - else - size = f__typesize[type]; - l_write(&number, v->addr, size, type); - if (vd < vde) { - if (f__recpos+2 >= L_len) - nl_donewrec(); - PUT(','); - PUT(' '); - } - else if (f__recpos+1 >= L_len) - nl_donewrec(); - } - f__Aquote = 0; - PUT('/'); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/z_abs.c b/ext/f2c_libs/z_abs.c deleted file mode 100644 index 4d8a015d3..000000000 --- a/ext/f2c_libs/z_abs.c +++ /dev/null @@ -1,18 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -double f__cabs(); -double z_abs(z) doublecomplex *z; -#else -double f__cabs(double, double); -double z_abs(doublecomplex *z) -#endif -{ -return( f__cabs( z->r, z->i ) ); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/z_cos.c b/ext/f2c_libs/z_cos.c deleted file mode 100644 index 4abe8bf88..000000000 --- a/ext/f2c_libs/z_cos.c +++ /dev/null @@ -1,21 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double sin(), cos(), sinh(), cosh(); -VOID z_cos(r, z) doublecomplex *r, *z; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -void z_cos(doublecomplex *r, doublecomplex *z) -#endif -{ - double zi = z->i, zr = z->r; - r->r = cos(zr) * cosh(zi); - r->i = - sin(zr) * sinh(zi); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/z_div.c b/ext/f2c_libs/z_div.c deleted file mode 100644 index b61f03b8e..000000000 --- a/ext/f2c_libs/z_div.c +++ /dev/null @@ -1,50 +0,0 @@ -#include "f2c.h" -#ifdef __cplusplus -extern "C" { -#endif - -#ifdef KR_headers -extern VOID sig_die(); -VOID z_div(c, a, b) doublecomplex *a, *b, *c; -#else -extern void sig_die(char*, int); -void z_div(doublecomplex *c, doublecomplex *a, doublecomplex *b) -#endif -{ - double ratio, den; - double abr, abi, cr; - - if( (abr = b->r) < 0.) - abr = - abr; - if( (abi = b->i) < 0.) - abi = - abi; - if( abr <= abi ) - { - if(abi == 0) { -#ifdef IEEE_COMPLEX_DIVIDE - if (a->i != 0 || a->r != 0) - abi = 1.; - c->i = c->r = abi / abr; - return; -#else - sig_die("complex division by zero", 1); -#endif - } - ratio = b->r / b->i ; - den = b->i * (1 + ratio*ratio); - cr = (a->r*ratio + a->i) / den; - c->i = (a->i*ratio - a->r) / den; - } - - else - { - ratio = b->i / b->r ; - den = b->r * (1 + ratio*ratio); - cr = (a->r + a->i*ratio) / den; - c->i = (a->i - a->r*ratio) / den; - } - c->r = cr; - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/z_exp.c b/ext/f2c_libs/z_exp.c deleted file mode 100644 index 7b8edfece..000000000 --- a/ext/f2c_libs/z_exp.c +++ /dev/null @@ -1,23 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double exp(), cos(), sin(); -VOID z_exp(r, z) doublecomplex *r, *z; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -void z_exp(doublecomplex *r, doublecomplex *z) -#endif -{ - double expx, zi = z->i; - - expx = exp(z->r); - r->r = expx * cos(zi); - r->i = expx * sin(zi); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/z_log.c b/ext/f2c_libs/z_log.c deleted file mode 100644 index 4f11bbe0c..000000000 --- a/ext/f2c_libs/z_log.c +++ /dev/null @@ -1,121 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double log(), f__cabs(), atan2(); -#define ANSI(x) () -#else -#define ANSI(x) x -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -extern double f__cabs(double, double); -#endif - -#ifndef NO_DOUBLE_EXTENDED -#ifndef GCC_COMPARE_BUG_FIXED -#ifndef Pre20000310 -#ifdef Comment -Some versions of gcc, such as 2.95.3 and 3.0.4, are buggy under -O2 or -O3: -on IA32 (Intel 80x87) systems, they may do comparisons on values computed -in extended-precision registers. This can lead to the test "s > s0" that -was used below being carried out incorrectly. The fix below cannot be -spoiled by overzealous optimization, since the compiler cannot know -whether gcc_bug_bypass_diff_F2C will be nonzero. (We expect it always -to be zero. The weird name is unlikely to collide with anything.) - -An example (provided by Ulrich Jakobus) where the bug fix matters is - - double complex a, b - a = (.1099557428756427618354862829619, .9857360542953131909982289471372) - b = log(a) - -An alternative to the fix below would be to use 53-bit rounding precision, -but the means of specifying this 80x87 feature are highly unportable. -#endif /*Comment*/ -#define BYPASS_GCC_COMPARE_BUG -double (*gcc_bug_bypass_diff_F2C) ANSI((double*,double*)); - static double -#ifdef KR_headers -diff1(a,b) double *a, *b; -#else -diff1(double *a, double *b) -#endif -{ return *a - *b; } -#endif /*Pre20000310*/ -#endif /*GCC_COMPARE_BUG_FIXED*/ -#endif /*NO_DOUBLE_EXTENDED*/ - -#ifdef KR_headers -VOID z_log(r, z) doublecomplex *r, *z; -#else -void z_log(doublecomplex *r, doublecomplex *z) -#endif -{ - double s, s0, t, t2, u, v; - double zi = z->i, zr = z->r; -#ifdef BYPASS_GCC_COMPARE_BUG - double (*diff) ANSI((double*,double*)); -#endif - - r->i = atan2(zi, zr); -#ifdef Pre20000310 - r->r = log( f__cabs( zr, zi ) ); -#else - if (zi < 0) - zi = -zi; - if (zr < 0) - zr = -zr; - if (zr < zi) { - t = zi; - zi = zr; - zr = t; - } - t = zi/zr; - s = zr * sqrt(1 + t*t); - /* now s = f__cabs(zi,zr), and zr = |zr| >= |zi| = zi */ - if ((t = s - 1) < 0) - t = -t; - if (t > .01) - r->r = log(s); - else { - -#ifdef Comment - - log(1+x) = x - x^2/2 + x^3/3 - x^4/4 + - ... - - = x(1 - x/2 + x^2/3 -+...) - - [sqrt(y^2 + z^2) - 1] * [sqrt(y^2 + z^2) + 1] = y^2 + z^2 - 1, so - - sqrt(y^2 + z^2) - 1 = (y^2 + z^2 - 1) / [sqrt(y^2 + z^2) + 1] - -#endif /*Comment*/ - -#ifdef BYPASS_GCC_COMPARE_BUG - if (!(diff = gcc_bug_bypass_diff_F2C)) - diff = diff1; -#endif - t = ((zr*zr - 1.) + zi*zi) / (s + 1); - t2 = t*t; - s = 1. - 0.5*t; - u = v = 1; - do { - s0 = s; - u *= t2; - v += 2; - s += u/v - t*u/(v+1); - } -#ifdef BYPASS_GCC_COMPARE_BUG - while(s - s0 > 1e-18 || (*diff)(&s,&s0) > 0.); -#else - while(s > s0); -#endif - r->r = s*t; - } -#endif - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/z_sin.c b/ext/f2c_libs/z_sin.c deleted file mode 100644 index 01225a944..000000000 --- a/ext/f2c_libs/z_sin.c +++ /dev/null @@ -1,21 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double sin(), cos(), sinh(), cosh(); -VOID z_sin(r, z) doublecomplex *r, *z; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -void z_sin(doublecomplex *r, doublecomplex *z) -#endif -{ - double zi = z->i, zr = z->r; - r->r = sin(zr) * cosh(zi); - r->i = cos(zr) * sinh(zi); - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_libs/z_sqrt.c b/ext/f2c_libs/z_sqrt.c deleted file mode 100644 index 35bd44c8e..000000000 --- a/ext/f2c_libs/z_sqrt.c +++ /dev/null @@ -1,35 +0,0 @@ -#include "f2c.h" - -#ifdef KR_headers -double sqrt(), f__cabs(); -VOID z_sqrt(r, z) doublecomplex *r, *z; -#else -#undef abs -#include "math.h" -#ifdef __cplusplus -extern "C" { -#endif -extern double f__cabs(double, double); -void z_sqrt(doublecomplex *r, doublecomplex *z) -#endif -{ - double mag, zi = z->i, zr = z->r; - - if( (mag = f__cabs(zr, zi)) == 0.) - r->r = r->i = 0.; - else if(zr > 0) - { - r->r = sqrt(0.5 * (mag + zr) ); - r->i = zi / r->r / 2; - } - else - { - r->i = sqrt(0.5 * (mag - zr) ); - if(zi < 0) - r->i = - r->i; - r->r = zi / r->i / 2; - } - } -#ifdef __cplusplus -} -#endif diff --git a/ext/f2c_math/cblas.h b/ext/f2c_math/cblas.h deleted file mode 100644 index 8ca35aa1a..000000000 --- a/ext/f2c_math/cblas.h +++ /dev/null @@ -1,646 +0,0 @@ -// -*- C++ -*- - -// ============================================= // -// die double-Versionen der BLAS Level 1 und 2 // -// ============================================= // - -#ifndef CBLAS1_H -// ============================================================================ - -// generate a plane rotation -void drotg( double *a, double *b, double *c, double *s ); - - -#if 0 -// generate a modified plane rotation -void drotmg( double *d1, double *d2, double *a, double b, double *param ); -#endif - -// apply a plane rotation -void drot( int n, double *x, int incx, double *y, int incy, double c, - double s ); - - -#if 0 -// apply a modified plane rotation -void drotm( int n, double *x, int incx, double *y, int incy, double *param ); -#endif - - -// x <=> y -void dswap( int n, double *x, int incx, double *y, int incy ); - - -// x <= a*x -void dscal( int n, double alpha, double *x, int incx ); - - -// y <= x -void dcopy( int n, const double *x, int incx, double *y, int incy ); - - -// y <= a*x+y -void daxpy( int n, double alpha, const double *x, int incx, double *y, - int incy ); - - -// dot <= x^T*y -double ddot( int n, const double *x, int incx, const double *y, int incy ); - - -// dnrm2 <= |x|_2 -double dnrm2( int n, const double *x, int incx ); - - -// asum <= |x|_1 -double dasum( int n, const double *x, int incx ); - - -// idamax <= first k such that |x_k| = max|x_i| -int idamax( int n, const double *x, int incx ); - -// ============================================================================ -#endif // CBLAS1_H - - -#ifndef CBLAS2_H -// ============================================================================ - - -enum MatrixTranspose { NoTranspose=0, Transpose=1, ConjugateTranspose=2 }; -enum MatrixTriangle { UpperTriangle=0, LowerTriangle=1 }; -enum MatrixUnitTriangular { UnitTriangular=0, NotUnitTriangular=1 }; - - -// ============================================================================ - - -// y <= alpha*A*x + beta*y, y <= alpha*A^T*x + beta*y, A-(m,n) -void dgemv( MatrixTranspose trans, int m, int n, double alpha, - const double *A, int ldA, const double *x, int incx, - double beta, double *y, int incy ); - - -// y <= alpha*A*x + beta*y, y <= alpha*A^T*x + beta*y, A-(m,n) -void dgbmv( MatrixTranspose trans, int m, int n, int kl, int ku, double alpha, - const double *A, int ldA, const double *x, int incx, double *beta, - double *y, int incy ); - - -// y <= alpha*A*x + beta*y -void dsymv( MatrixTriangle uplo, int n, double alpha, const double *A, int ldA, - const double *x, int incx, double beta, double *y, int incy ); - - -// y <= alpha*A*x + beta*y -void dsbmv( MatrixTriangle uplo, int n, int k, double alpha, double *A, - int ldA, const double *x, int incx, double beta, double *y, - int *incy ); - - -// y <= alpha*A*x + beta*y -void dspmv( MatrixTriangle uplo, int n, double alpha, const double *AP, - const double *x, int incx, double beta, double *y, int incy ); - - -// x <= A*x, x <= A^T*x -void dtrmv( MatrixTriangle uplo, MatrixTranspose trans, - MatrixUnitTriangular diag, int n, const double *A, int ldA, - double *x, int incx ); - - -// x <= A*x, x <= A^T*x -void dtbmv( MatrixTriangle uplo, MatrixTranspose trans, - MatrixUnitTriangular diag, int n, int k, const double *A, int ldA, - double *x, int incx ); - - -// x <= A*x, x <= A^T*x -void dtpmv( MatrixTriangle uplo, MatrixTranspose trans, - MatrixUnitTriangular diag, int n, int k, const double *AP, - double *x, int incx ); - - -// x <= A^{-1}*x, x <= A^{-T}*x -void dtrsv( MatrixTriangle uplo, MatrixTranspose trans, - MatrixUnitTriangular diag, int n, const double *A, int ldA, - double *x, int incx ); - - -// x <= A^{-1}*x, x <= A^{-T}*x -void dtbsv( MatrixTriangle uplo, MatrixTranspose trans, - MatrixUnitTriangular diag, int n, int k, const double *A, int ldA, - double *x, int incx ); - - -// x <= A^{-1}*x, x <= A^{-T}*x -void dtpsv( MatrixTriangle uplo, MatrixTranspose trans, - MatrixUnitTriangular diag, int n, int k, const double *AP, - double *x, int incx ); - - -// A <= alpha*x*y^T + A, A-(m,n) -void dger( int m, int n, double alpha, const double *x, int incx, - const double *y, int incy, double *A, int ldA ); - - -// A <= alpha*x*x^T + A -void dsyr( MatrixTriangle uplo, int n, double alpha, const double *x, - int incx, double *A, int ldA ); - - -// A <= alpha*x*x^T + A -void dspr( MatrixTriangle uplo, int n, double alpha, const double *x, - int incx, double *AP ); - - -// A <= alpha*x*y^T + alpha*y*x^T + A -void dsyr2( MatrixTriangle uplo, int n, double alpha, const double *x, - int incx, const double *y, int incy, double *A, int ldA ); - - -// A <= alpha*x*y^T + alpha*y*x^T + A -void dspr2( MatrixTriangle uplo, int n, double alpha, const double *x, - int incx, const double *y, int incy, double *AP ); - -// ============================================================================ -#endif // CBLAS2_H - - -#ifndef BLAS1_H -#define BLAS1_H -// ============================================================================ - -// generate a plane rotation -extern "C" -void drotg_( double *a, double *b, double *c, double *s ); - - -#if 0 -// generate a modified plane rotation -extern "C" -void drotmg_( double *d1, double *d2, double *a, double *b, double *param ); -#endif - - -// apply a plane rotation -extern "C" -void drot_( int *n, double *x, int *incx, double *y, int *incy, - double *c, double *s ); - - -#if 0 -// apply a modified plane rotation -extern "C" -void drotm_( int *n, double *x, int *incx, double *y, int *incy, - double *param ); -#endif - - -// x <=> y -extern "C" -void dswap_( const int *n, double *x, const int *incx, double *y, - const int *incy ); - -// x <= a*x -extern "C" -void dscal_( const int *n, const double *alpha, double *x, const int *incx ); - - -// y <= x -extern "C" -void dcopy_( const int *n, const double *x, const int *incx, double *y, - const int *incy ); - - -// y <= a*x+y -extern "C" -void daxpy_( const int *n, const double *alpha, const double *x, - const int *incx, double *y, const int *incy ); - - -// dot <= x^T*y -extern "C" -double ddot_( const int *n, const double *x, const int *incx, const double *y, - const int *incy ); - - -// dnrm2 <= |x|_2 -extern "C" -double dnrm2_( const int *n, const double *x, const int *incx ); - - -// asum <= |x|_1 -extern "C" -double dasum_( const int *n, const double *x, const int *incx ); - - -// idamax <= first k such that |x_k| = max|x_i| -extern "C" -int idamax_( const int *n, const double *x, const int *incx ); - - -// ============================================================================ -#endif // BLAS1_H - - - -#ifndef CBLAS1_H -#define CBLAS1_H -// ============================================================================ - - -#ifdef __linux__ // muss dnorm2 f"ur linux neu implementieren -# include -#endif - -inline -void drotg( double *a, double *b, double *c, double *s ) { - drotg_(a,b,c,s); -} - -#if 0 -inline -void drotmg( double *d1, double *d2, double *a, double b, double *param ) { - drotmg_(d1,d2,a,&b,param); -} -#endif - -inline -void drot( int n, double *x, int incx, double *y, int incy, double c, - double s ) { - drot_(&n,x,&incx,y,&incy,&c,&s); -} - -#if 0 -inline -void drotm( int n, double *x, int incx, double *y, int incy, double *param ) { - drotm_(&n,x,&incx,y,&incy,param); -} -#endif - -inline -void dswap( int n, double *x, int incx, double *y, int incy ) { - dswap_(&n,x,&incx,y,&incy); -} - -inline -void dscal( int n, double alpha, double *x, int incx ) { - int nn = n; - int incxx = incx; - double aa = alpha; - dscal_(&nn,&aa,x,&incxx); -} - -inline -void dcopy( int n, const double *x, int incx, double *y, int incy ) { - int nn = n; - int incxx = incx; - int incyy = incy; - dcopy_(&nn,x,&incxx,y,&incyy); -} - -inline -void daxpy( int n, double alpha, const double *x, int incx, double *y, - int incy ) { - double aa = alpha; - int incxx = incx; - int incyy = incy; - daxpy_(&n,&aa,x,&incxx,y,&incyy); -} - -inline -double ddot( int n, const double *x, int incx, const double *y, int incy ) { - int nn = n; - int incxx = incx; - int incyy = incy; - return ddot_(&nn,x,&incxx,y,&incyy); -} - -inline -double dnrm2( int n, const double *x, int incx ) { - int nn = n; - int incxx = incx; -#ifdef __linux__ // fehlerhafte Berechnung - double d=0.; - while ( nn-- ) - d+=(*x)*(*x), x+=incxx; - return sqrt(d); -#else // unter nicht-Linux korrekt - return dnrm2_(&nn,x,&incxx); -#endif -} - -inline -double dasum( int n, const double *x, int incx ) { - return dasum_(&n,x,&incx); -} - -inline -int idamax( int n, const double *x, int incx ) { - return idamax_(&n,x,&incx); -} - - -// ============================================================================ -#endif // CBLAS1_H - - -#ifndef BLAS2_H -#define BLAS2_H -// ============================================================================ - -// y <= alpha*A*x + beta*y, y <= alpha*A^T*x + beta*y, A-(m,n) -//extern "C" -//void dgemv_( const char *trans, const int *m, const int *n, -// const double *alpha, const double *A, const int *ldA, -// const double *x, const int *incx, -// const double *beta, double *y, const int *incy ); - - -// y <= alpha*A*x + beta*y, y <= alpha*A^T*x + beta*y, A-(m,n) -extern "C" -void dgbmv_( const char *trans, const int *m, const int *n, const int *kl, - const int *ku, const double *alpha, const double *A, - const int *ldA, const double *x, const int *incx, - const double *beta, double *y, const int *incy ); - - -// y <= alpha*A*x + beta*y -extern "C" -void dsymv_( const char *uplo, const int *n, const double *alpha, - const double *A, const int *ldA, const double *x, const int *incx, - const double *beta, double *y, const int *incy ); - - -// y <= alpha*A*x + beta*y -extern "C" -void dsbmv_( const char *uplo, const int *n, const int *k, const double *alpha, - const double *A, const int *ldA, const double *x, const int *incx, - const double *beta, double *y, const int *incy ); - - -// y <= alpha*A*x + beta*y -extern "C" -void dspmv_( const char *uplo, const int *n, const double *alpha, - const double *AP, const double *x, const int *incx, - const double *beta, double *y, const int *incy ); - - -// x <= A*x, x <= A^T*x -extern "C" -void dtrmv_( const char *uplo, const char *trans, const char *diag, - const int *n, const double *A, const int *ldA, - double *x, const int *incx ); - - -// x <= A*x, x <= A^T*x -extern "C" -void dtbmv_( const char *uplo, const char *trans, const char *diag, - const int *n, const int *k, const double *A, const int *ldA, - double *x, const int *incx ); - - -// x <= A*x, x <= A^T*x -extern "C" -void dtpmv_( const char *uplo, const char *trans, const char *diag, - const int *n, const double *AP, double *x, const int *incx ); - - -// x <= A^{-1}*x, x <= A^{-T}*x -extern "C" -void dtrsv_( const char *uplo, const char *trans, const char *diag, - const int *n, const double *A, const int *ldA, - double *x, const int *incx ); - - -// x <= A^{-1}*x, x <= A^{-T}*x -extern "C" -void dtbsv_( const char *uplo, const char *trans, const char *diag, - const int *n, const int *k, const double *A, const int *ldA, - double *x, const int *incx ); - - -// x <= A^{-1}*x, x <= A^{-T}*x -extern "C" -void dtpsv_( const char *uplo, const char *trans, const char *diag, - const int *n, const double *AP, double *x, const int *incx ); - - -// A <= alpha*x*y^T + A, A-(m,n) -extern "C" -void dger_( const int *m, const int *n, const double *alpha, const double *x, - const int *incx, const double *y, const int *incy, double *A, - const int *ldA ); - - -// A <= alpha*x*x^T + A -extern "C" -void dsyr_( const char *uplo, const int *n, const double *alpha, - const double *x, const int *incx, double *A, const int *ldA ); - - -// A <= alpha*x*x^T + A -extern "C" -void dspr_( const char *uplo, const int *n, const double *alpha, - const double *x, const int *incx, double *AP ); - - -// A <= alpha*x*y^T + alpha*y*x^T + A -extern "C" -void dsyr2_( const char *uplo, const int *n, const double *alpha, - const double *x, const int *incx, const double *y, - const int *incy, double *A, const int *ldA ); - - -// A <= alpha*x*y^T + alpha*y*x^T + A -extern "C" -void dspr2_( const char *uplo, const int *n, const double *alpha, - const double *x, const int *incx, const double *y, - const int *incy, double *AP ); - -// ============================================================================ -#endif // BLAS2_H - - -#ifndef CBLAS2_H -#define CBLAS2_H -// ============================================================================ - - -// y <= alpha*A*x + beta*y, y <= alpha*A^T*x + beta*y, A-(m,n) -inline -void dgemv( MatrixTranspose trans, int m, int n, double alpha, - const double *A, int ldA, const double *x, int incx, - double beta, double *y, int incy ) { - const char *T[3] = { "N", "T", 0 }; - int mm = m; - int nn = n; - double aa = alpha; - double bb = beta; - int ldaa = ldA; - int incxx = incx; - int incyy = incy; - dgemv_(T[(int)trans],&mm,&nn,&aa,A,&ldaa,x,&incxx,&bb,y,&incyy,1); -} - - -// y <= alpha*A*x + beta*y, y <= alpha*A^T*x + beta*y, A-(m,n) -inline -void dgbmv( MatrixTranspose trans, int m, int n, int kl, int ku, double alpha, - const double *A, int ldA, const double *x, int incx, double beta, - double *y, int incy ) { - const char *T[3] = { "N", "T" }; - dgbmv_(T[(int)trans],&m,&n,&kl,&ku,&alpha,A,&ldA,x,&incx,&beta,y,&incy); -} - -// y <= alpha*A*x + beta*y -inline -void dsymv( MatrixTriangle uplo, int n, double alpha, const double *A, int ldA, - const double *x, int incx, double beta, double *y, int incy ) { - const char *UL[2] = { "U", "L" }; - dsymv_(UL[(int)uplo],&n,&alpha,A,&ldA,x,&incx,&beta,y,&incy); -} - - -// y <= alpha*A*x + beta*y -inline -void dsbmv( MatrixTriangle uplo, int n, int k, double alpha, double *A, - int ldA, const double *x, int incx, double beta, double *y, - int incy ) { - const char *UL[2] = { "U", "L" }; - dsbmv_(UL[(int)uplo],&n,&k,&alpha,A,&ldA,x,&incx,&beta,y,&incy); -} - - -// y <= alpha*A*x + beta*y -inline -void dspmv( MatrixTriangle uplo, int n, double alpha, const double *AP, - const double *x, int incx, double beta, double *y, int incy ) { - const char *UL[2] = { "U", "L" }; - dspmv_(UL[(int)uplo],&n,&alpha,AP,x,&incx,&beta,y,&incy); -} - - -// x <= A*x, x <= A^T*x -inline -void dtrmv( MatrixTriangle uplo, MatrixTranspose trans, - MatrixUnitTriangular diag, int n, const double *A, int ldA, - double *x, int incx ) { - const char *UL[2] = { "U", "L" }; - const char *T[3] = { "N", "T", 0 }; - const char *D[2] = { "U", "N" }; - dtrmv_(UL[(int)uplo],T[(int)trans],D[(int)diag],&n,A,&ldA,x,&incx); -} - - -// x <= A*x, x <= A^T*x -inline -void dtbmv( MatrixTriangle uplo, MatrixTranspose trans, - MatrixUnitTriangular diag, int n, int k, const double *A, int ldA, - double *x, int incx ) { - const char *UL[2] = { "U", "L" }; - const char *T[3] = { "N", "T", 0 }; - const char *D[2] = { "U", "N" }; - dtbmv_(UL[(int)uplo],T[(int)trans],D[(int)diag],&n,&k,A,&ldA,x,&incx); -} - - -// x <= A*x, x <= A^T*x -inline -void dtpmv( MatrixTriangle uplo, MatrixTranspose trans, - MatrixUnitTriangular diag, int n, const double *AP, - double *x, int incx ) { - const char *UL[2] = { "U", "L" }; - const char *T[3] = { "N", "T", 0 }; - const char *D[2] = { "U", "N" }; - dtpmv_(UL[(int)uplo],T[(int)trans],D[(int)diag],&n,AP,x,&incx); -} - - -// x <= A^{-1}*x, x <= A^{-T}*x -inline -void dtrsv( MatrixTriangle uplo, MatrixTranspose trans, - MatrixUnitTriangular diag, int n, const double *A, int ldA, - double *x, int incx ) { - const char *UL[2] = { "U", "L" }; - const char *T[3] = { "N", "T", 0 }; - const char *D[2] = { "U", "N" }; - dtrsv_(UL[(int)uplo],T[(int)trans],D[(int)diag],&n,A,&ldA,x,&incx); -} - - -// x <= A^{-1}*x, x <= A^{-T}*x -inline -void dtbsv( MatrixTriangle uplo, MatrixTranspose trans, - MatrixUnitTriangular diag, int n, int k, const double *A, int ldA, - double *x, int incx ) { - const char *UL[2] = { "U", "L" }; - const char *T[3] = { "N", "T", 0 }; - const char *D[2] = { "U", "N" }; - dtbsv_(UL[(int)uplo],T[(int)trans],D[(int)diag],&n,&k,A,&ldA,x,&incx); -} - - -// x <= A^{-1}*x, x <= A^{-T}*x -inline -void dtpsv( MatrixTriangle uplo, MatrixTranspose trans, - MatrixUnitTriangular diag, int n, const double *AP, - double *x, int incx ) { - const char *UL[2] = { "U", "L" }; - const char *T[3] = { "N", "T", 0 }; - const char *D[2] = { "U", "N" }; - int nn = n; - int incxx = incx; - dtpsv_(UL[(int)uplo],T[(int)trans],D[(int)diag],&nn,AP,x,&incxx); -} - - -// A <= alpha*x*y^T + A, A-(m,n) -inline -void dger( int m, int n, double alpha, const double *x, int incx, - const double *y, int incy, double *A, int ldA ) { - dger_(&m,&n,&alpha,x,&incx,y,&incy,A,&ldA); -} - - -// A <= alpha*x*x^T + A -inline -void dsyr( MatrixTriangle uplo, int n, double alpha, const double *x, - int incx, double *A, int ldA ) { - const char *UL[2] = { "U", "L" }; - dsyr_(UL[(int)uplo],&n,&alpha,x,&incx,A,&ldA); -} - - -// A <= alpha*x*x^T + A -inline -void dspr( MatrixTriangle uplo, int n, double alpha, const double *x, - int incx, double *AP ) { - const char *UL[2] = { "U", "L" }; - dspr_(UL[(int)uplo],&n,&alpha,x,&incx,AP); -} - - -// A <= alpha*x*y^T + alpha*y*x^T + A -inline -void dsyr2( MatrixTriangle uplo, int n, double alpha, const double *x, - int incx, const double *y, int incy, double *A, int ldA ) { - const char *UL[2] = { "U", "L" }; - dsyr2_(UL[(int)uplo],&n,&alpha,x,&incx,y,&incy,A,&ldA); -} - - -// A <= alpha*x*y^T + alpha*y*x^T + A -inline -void dspr2( MatrixTriangle uplo, int n, double alpha, const double *x, - int incx, const double *y, int incy, double *AP ) { - const char *UL[2] = { "U", "L" }; - dspr2_(UL[(int)uplo],&n,&alpha,x,&incx,y,&incy,AP); -} - - -// ============================================================================ - - -#endif // CBLAS2_H diff --git a/ext/f2c_math/daux.c b/ext/f2c_math/daux.c deleted file mode 100644 index 3af7c6312..000000000 --- a/ext/f2c_math/daux.c +++ /dev/null @@ -1,345 +0,0 @@ -/* daux.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__0 = 0; -static logical c_false = FALSE_; -static integer c__2 = 2; -static logical c_true = TRUE_; - -/* DOUBLE PRECISION FUNCTION D1MACH (IDUM) */ -/* INTEGER IDUM */ -/* C----------------------------------------------------------------------- */ -/* C THIS ROUTINE COMPUTES THE UNIT ROUNDOFF OF THE MACHINE IN DOUBLE */ -/* C PRECISION. THIS IS DEFINED AS THE SMALLEST POSITIVE MACHINE NUMBER */ -/* C U SUCH THAT 1.0D0 + U .NE. 1.0D0 (IN DOUBLE PRECISION). */ -/* C----------------------------------------------------------------------- */ -/* DOUBLE PRECISION U, COMP */ -/* U = 1.0D0 */ -/* 10 U = U*0.5D0 */ -/* COMP = 1.0D0 + U */ -/* IF (COMP .NE. 1.0D0) GO TO 10 */ -/* D1MACH = U*2.0D0 */ -/* RETURN */ -/* C----------------------- END OF FUNCTION D1MACH ------------------------ */ -/* END */ -/* DECK XERRWD */ -/* Subroutine */ int xerrwd_(char *msg, integer *nmes, integer *nerr, integer - *level, integer *ni, integer *i1, integer *i2, integer *nr, - doublereal *r1, doublereal *r2, ftnlen msg_len) -{ - /* Format strings */ - static char fmt_10[] = "(1x,a)"; - static char fmt_20[] = "(6x,\002In above message, I1 =\002,i10)"; - static char fmt_30[] = "(6x,\002In above message, I1 =\002,i10,3x,\002I" - "2 =\002,i10)"; - static char fmt_40[] = "(6x,\002In above message, R1 =\002,d21.13)"; - static char fmt_50[] = "(6x,\002In above, R1 =\002,d21.13,3x,\002R2 " - "=\002,d21.13)"; - - /* Builtin functions */ - integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void); - /* Subroutine */ int s_stop(char *, ftnlen); - - /* Local variables */ - extern integer ixsav_(integer *, integer *, logical *); - integer lunit, mesflg; - - /* Fortran I/O blocks */ - static cilist io___3 = { 0, 0, 0, fmt_10, 0 }; - static cilist io___4 = { 0, 0, 0, fmt_20, 0 }; - static cilist io___5 = { 0, 0, 0, fmt_30, 0 }; - static cilist io___6 = { 0, 0, 0, fmt_40, 0 }; - static cilist io___7 = { 0, 0, 0, fmt_50, 0 }; - - -/* ***BEGIN PROLOGUE XERRWD */ -/* ***SUBSIDIARY */ -/* ***PURPOSE Write error message with values. */ -/* ***LIBRARY MATHLIB */ -/* ***CATEGORY R3C */ -/* ***TYPE DOUBLE PRECISION (XERRWV-S, XERRWD-D) */ -/* ***AUTHOR Hindmarsh, Alan C., (LLNL) */ -/* ***DESCRIPTION */ - -/* Subroutines XERRWD, XSETF, XSETUN, and the function routine IXSAV, */ -/* as given here, constitute a simplified version of the SLATEC error */ -/* handling package. */ - -/* All arguments are input arguments. */ - -/* MSG = The message (character array). */ -/* NMES = The length of MSG (number of characters). */ -/* NERR = The error number (not used). */ -/* LEVEL = The error level.. */ -/* 0 or 1 means recoverable (control returns to caller). */ -/* 2 means fatal (run is aborted--see note below). */ -/* NI = Number of integers (0, 1, or 2) to be printed with message. */ -/* I1,I2 = Integers to be printed, depending on NI. */ -/* NR = Number of reals (0, 1, or 2) to be printed with message. */ -/* R1,R2 = Reals to be printed, depending on NR. */ - -/* Note.. this routine is machine-dependent and specialized for use */ -/* in limited context, in the following ways.. */ -/* 1. The argument MSG is assumed to be of type CHARACTER, and */ -/* the message is printed with a format of (1X,A). */ -/* 2. The message is assumed to take only one line. */ -/* Multi-line messages are generated by repeated calls. */ -/* 3. If LEVEL = 2, control passes to the statement STOP */ -/* to abort the run. This statement may be machine-dependent. */ -/* 4. R1 and R2 are assumed to be in double precision and are printed */ -/* in D21.13 format. */ - -/* ***ROUTINES CALLED IXSAV */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 920831 DATE WRITTEN */ -/* 921118 Replaced MFLGSV/LUNSAV by IXSAV. (ACH) */ -/* 930329 Modified prologue to SLATEC format. (FNF) */ -/* 930407 Changed MSG from CHARACTER*1 array to variable. (FNF) */ -/* 930922 Minor cosmetic change. (FNF) */ -/* ***END PROLOGUE XERRWD */ - -/* *Internal Notes: */ - -/* For a different default logical unit number, IXSAV (or a subsidiary */ -/* routine that it calls) will need to be modified. */ -/* For a different run-abort command, change the statement following */ -/* statement 100 at the end. */ -/* ----------------------------------------------------------------------- */ -/* Subroutines called by XERRWD.. None */ -/* Function routine called by XERRWD.. IXSAV */ -/* ----------------------------------------------------------------------- */ -/* **End */ - -/* Declare arguments. */ - - -/* Declare local variables. */ - - -/* Get logical unit number and message print flag. */ - -/* ***FIRST EXECUTABLE STATEMENT XERRWD */ - lunit = ixsav_(&c__1, &c__0, &c_false); - mesflg = ixsav_(&c__2, &c__0, &c_false); - if (mesflg == 0) { - goto L100; - } - -/* Write the message. */ - - io___3.ciunit = lunit; - s_wsfe(&io___3); - do_fio(&c__1, msg, msg_len); - e_wsfe(); - if (*ni == 1) { - io___4.ciunit = lunit; - s_wsfe(&io___4); - do_fio(&c__1, (char *)&(*i1), (ftnlen)sizeof(integer)); - e_wsfe(); - } - if (*ni == 2) { - io___5.ciunit = lunit; - s_wsfe(&io___5); - do_fio(&c__1, (char *)&(*i1), (ftnlen)sizeof(integer)); - do_fio(&c__1, (char *)&(*i2), (ftnlen)sizeof(integer)); - e_wsfe(); - } - if (*nr == 1) { - io___6.ciunit = lunit; - s_wsfe(&io___6); - do_fio(&c__1, (char *)&(*r1), (ftnlen)sizeof(doublereal)); - e_wsfe(); - } - if (*nr == 2) { - io___7.ciunit = lunit; - s_wsfe(&io___7); - do_fio(&c__1, (char *)&(*r1), (ftnlen)sizeof(doublereal)); - do_fio(&c__1, (char *)&(*r2), (ftnlen)sizeof(doublereal)); - e_wsfe(); - } - -/* Abort the run if LEVEL = 2. */ - -L100: - if (*level != 2) { - return 0; - } - s_stop("", (ftnlen)0); -/* ----------------------- End of Subroutine XERRWD ---------------------- */ - return 0; -} /* xerrwd_ */ - -/* DECK XSETF */ -/* Subroutine */ int xsetf_(integer *mflag) -{ - integer junk; - extern integer ixsav_(integer *, integer *, logical *); - -/* ***BEGIN PROLOGUE XSETF */ -/* ***PURPOSE Reset the error print control flag. */ -/* ***LIBRARY MATHLIB */ -/* ***CATEGORY R3A */ -/* ***TYPE ALL (XSETF-A) */ -/* ***KEYWORDS ERROR CONTROL */ -/* ***AUTHOR Hindmarsh, Alan C., (LLNL) */ -/* ***DESCRIPTION */ - -/* XSETF sets the error print control flag to MFLAG: */ -/* MFLAG=1 means print all messages (the default). */ -/* MFLAG=0 means no printing. */ - -/* ***SEE ALSO XERMSG, XERRWD, XERRWV */ -/* ***REFERENCES (NONE) */ -/* ***ROUTINES CALLED IXSAV */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 921118 DATE WRITTEN */ -/* 930329 Added SLATEC format prologue. (FNF) */ -/* 930407 Corrected SEE ALSO section. (FNF) */ -/* 930922 Made user-callable, and other cosmetic changes. (FNF) */ -/* ***END PROLOGUE XSETF */ - -/* Subroutines called by XSETF.. None */ -/* Function routine called by XSETF.. IXSAV */ -/* ----------------------------------------------------------------------- */ -/* **End */ - -/* ***FIRST EXECUTABLE STATEMENT XSETF */ - if (*mflag == 0 || *mflag == 1) { - junk = ixsav_(&c__2, mflag, &c_true); - } - return 0; -/* ----------------------- End of Subroutine XSETF ----------------------- */ -} /* xsetf_ */ - -/* DECK XSETUN */ -/* Subroutine */ int xsetun_(integer *lun) -{ - integer junk; - extern integer ixsav_(integer *, integer *, logical *); - -/* ***BEGIN PROLOGUE XSETUN */ -/* ***PURPOSE Reset the logical unit number for error messages. */ -/* ***LIBRARY MATHLIB */ -/* ***CATEGORY R3B */ -/* ***TYPE ALL (XSETUN-A) */ -/* ***KEYWORDS ERROR CONTROL */ -/* ***DESCRIPTION */ - -/* XSETUN sets the logical unit number for error messages to LUN. */ - -/* ***AUTHOR Hindmarsh, Alan C., (LLNL) */ -/* ***SEE ALSO XERMSG, XERRWD, XERRWV */ -/* ***REFERENCES (NONE) */ -/* ***ROUTINES CALLED IXSAV */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 921118 DATE WRITTEN */ -/* 930329 Added SLATEC format prologue. (FNF) */ -/* 930407 Corrected SEE ALSO section. (FNF) */ -/* 930922 Made user-callable, and other cosmetic changes. (FNF) */ -/* ***END PROLOGUE XSETUN */ - -/* Subroutines called by XSETUN.. None */ -/* Function routine called by XSETUN.. IXSAV */ -/* ----------------------------------------------------------------------- */ -/* **End */ - -/* ***FIRST EXECUTABLE STATEMENT XSETUN */ - if (*lun > 0) { - junk = ixsav_(&c__1, lun, &c_true); - } - return 0; -/* ----------------------- End of Subroutine XSETUN ---------------------- */ -} /* xsetun_ */ - -/* DECK IXSAV */ -integer ixsav_(integer *ipar, integer *ivalue, logical *iset) -{ - /* System generated locals */ - integer ret_val; - - /* Local variables */ - integer lunit, lundef, mesflg; - -/* ***BEGIN PROLOGUE IXSAV */ -/* ***SUBSIDIARY */ -/* ***PURPOSE Save and recall error message control parameters. */ -/* ***LIBRARY MATHLIB */ -/* ***CATEGORY R3C */ -/* ***TYPE ALL (IXSAV-A) */ -/* ***AUTHOR Hindmarsh, Alan C., (LLNL) */ -/* ***DESCRIPTION */ - -/* IXSAV saves and recalls one of two error message parameters: */ -/* LUNIT, the logical unit number to which messages are printed, and */ -/* MESFLG, the message print flag. */ -/* This is a modification of the SLATEC library routine J4SAVE. */ - -/* Saved local variables.. */ -/* LUNIT = Logical unit number for messages. */ -/* LUNDEF = Default logical unit number, data-loaded to 6 below */ -/* (may be machine-dependent). */ -/* MESFLG = Print control flag.. */ -/* 1 means print all messages (the default). */ -/* 0 means no printing. */ - -/* On input.. */ -/* IPAR = Parameter indicator (1 for LUNIT, 2 for MESFLG). */ -/* IVALUE = The value to be set for the parameter, if ISET = .TRUE. */ -/* ISET = Logical flag to indicate whether to read or write. */ -/* If ISET = .TRUE., the parameter will be given */ -/* the value IVALUE. If ISET = .FALSE., the parameter */ -/* will be unchanged, and IVALUE is a dummy argument. */ - -/* On return.. */ -/* IXSAV = The (old) value of the parameter. */ - -/* ***SEE ALSO XERMSG, XERRWD, XERRWV */ -/* ***ROUTINES CALLED NONE */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 921118 DATE WRITTEN */ -/* 930329 Modified prologue to SLATEC format. (FNF) */ -/* 941025 Minor modification re default unit number. (ACH) */ -/* ***END PROLOGUE IXSAV */ - -/* **End */ -/* ----------------------------------------------------------------------- */ -/* ----------------------------------------------------------------------- */ -/* The following Fortran-77 declaration is to cause the values of the */ -/* listed (local) variables to be saved between calls to this routine. */ -/* ----------------------------------------------------------------------- */ -/* SAVE LUNIT, LUNDEF, MESFLG */ -/* dgg mod 2/2007 */ - lunit = -1; - lundef = 6; - mesflg = 1; -/* DATA LUNIT/-1/, LUNDEF/6/, MESFLG/1/ */ - -/* ***FIRST EXECUTABLE STATEMENT IXSAV */ - if (*ipar == 1) { - if (lunit == -1) { - lunit = lundef; - } - ret_val = lunit; - if (*iset) { - lunit = *ivalue; - } - } - - if (*ipar == 2) { - ret_val = mesflg; - if (*iset) { - mesflg = *ivalue; - } - } - - return ret_val; -/* ----------------------- End of Function IXSAV ------------------------- */ -} /* ixsav_ */ - diff --git a/ext/f2c_math/ddaspk.c b/ext/f2c_math/ddaspk.c deleted file mode 100644 index 299eb91ae..000000000 --- a/ext/f2c_math/ddaspk.c +++ /dev/null @@ -1,8774 +0,0 @@ -/* ddaspk.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static long int lc__4 = 4; -static integer c__49 = 49; -static integer c__201 = 201; -static integer c__0 = 0; -static doublereal c_b37 = 0.; -static integer c__47 = 47; -static integer c__202 = 202; -static integer c__1 = 1; -static integer c__41 = 41; -static integer c__203 = 203; -static integer c__4 = 4; -static doublereal c_b67 = .6667; -static integer c__9 = 9; -static integer c__5 = 5; -static integer c__56 = 56; -static integer c__501 = 501; -static integer c__2 = 2; -static integer c__502 = 502; -static integer c__503 = 503; -static integer c__38 = 38; -static integer c__610 = 610; -static integer c__48 = 48; -static integer c__611 = 611; -static integer c__620 = 620; -static integer c__621 = 621; -static integer c__45 = 45; -static integer c__622 = 622; -static integer c__630 = 630; -static integer c__28 = 28; -static integer c__631 = 631; -static integer c__44 = 44; -static integer c__640 = 640; -static integer c__57 = 57; -static integer c__641 = 641; -static integer c__650 = 650; -static integer c__651 = 651; -static integer c__40 = 40; -static integer c__652 = 652; -static integer c__655 = 655; -static integer c__46 = 46; -static integer c__656 = 656; -static integer c__660 = 660; -static integer c__661 = 661; -static integer c__670 = 670; -static integer c__671 = 671; -static integer c__672 = 672; -static integer c__675 = 675; -static integer c__51 = 51; -static integer c__676 = 676; -static integer c__677 = 677; -static integer c__680 = 680; -static integer c__36 = 36; -static integer c__681 = 681; -static integer c__685 = 685; -static integer c__686 = 686; -static integer c__690 = 690; -static integer c__35 = 35; -static integer c__691 = 691; -static integer c__695 = 695; -static integer c__50 = 50; -static integer c__696 = 696; -static integer c__25 = 25; -static integer c__34 = 34; -static integer c__3 = 3; -static integer c__60 = 60; -static integer c__39 = 39; -static integer c__6 = 6; -static integer c__7 = 7; -static integer c__8 = 8; -static integer c__54 = 54; -static integer c__10 = 10; -static integer c__11 = 11; -static integer c__29 = 29; -static integer c__12 = 12; -static integer c__13 = 13; -static integer c__14 = 14; -static integer c__15 = 15; -static integer c__52 = 52; -static integer c__17 = 17; -static integer c__18 = 18; -static integer c__19 = 19; -static integer c__20 = 20; -static integer c__21 = 21; -static integer c__22 = 22; -static integer c__58 = 58; -static integer c__23 = 23; -static integer c__24 = 24; -static integer c__26 = 26; -static integer c__27 = 27; -static integer c__701 = 701; -static integer c__702 = 702; -static integer c__901 = 901; -static integer c__902 = 902; -static integer c__903 = 903; -static integer c__904 = 904; -static integer c__43 = 43; -static integer c__905 = 905; -static integer c__42 = 42; -static integer c__906 = 906; -static integer c__921 = 921; -static integer c__922 = 922; -static integer c__923 = 923; -static integer c__924 = 924; -static integer c__925 = 925; -static integer c__926 = 926; - -/* Subroutine */ int ddaspk_(U_fp res, integer *neq, doublereal *t, - doublereal *y, doublereal *yprime, doublereal *tout, integer *info, - doublereal *rtol, doublereal *atol, integer *idid, doublereal *rwork, - integer *lrw, integer *iwork, integer *liw, doublereal *rpar, integer - *ipar, U_fp jac, U_fp psol) -{ - /* System generated locals */ - integer i__1, i__2; - doublereal d__1, d__2; - - /* Builtin functions */ - /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); - double pow_dd(doublereal *, doublereal *), sqrt(doublereal), d_sign( - doublereal *, doublereal *); - integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), - e_wsle(void); - - /* Local variables */ - doublereal h__; - integer i__; - doublereal r__, h0; - integer le; - doublereal rh, tn; - integer ici, idi; - static integer lid; - integer ier; - char msg[80]; - integer lwm, lvt, lwt, nwt, nli0, nni0; - logical lcfl, lcfn, done; - doublereal rcfl; - integer nnid; - logical lavl; - integer maxl, iret; - doublereal hmax; - integer lphi; - doublereal hmin; - integer lyic, lpwk, nstd; - doublereal rcfn; - integer ncfl0, ncfn0; - extern /* Subroutine */ int dnedd_(); - integer mband; - extern /* Subroutine */ int dnedk_(); - integer lenic; - static integer lenid, ncphi; - integer lenpd, lsoff, msave, index, itemp, leniw, nzflg; - doublereal atoli; - integer lypic; - logical lwarn; - doublereal avlin; - integer lenwp, lenrw, mxord, nwarn; - doublereal rtoli; - integer lsavr; - extern doublereal d1mach_(long int *); - doublereal tdist, tnext, fmaxl; - extern /* Subroutine */ int ddstp_(doublereal *, doublereal *, doublereal - *, integer *, U_fp, U_fp, U_fp, doublereal *, doublereal *, - doublereal *, integer *, integer *, doublereal *, integer *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *, - integer *, integer *, integer *, integer *, integer *, integer *, - integer *, U_fp); - doublereal tstop; - extern /* Subroutine */ int dcnst0_(integer *, doublereal *, integer *, - integer *), ddasic_(doublereal *, doublereal *, doublereal *, - integer *, integer *, integer *, U_fp, U_fp, U_fp, doublereal *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - integer *, doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer * - , doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, integer *, integer *, integer *, U_fp) - ; - extern /* Subroutine */ int ddasid_(), ddasik_(); - integer icnflg; - doublereal tscale, epconi; - extern /* Subroutine */ int ddatrp_(doublereal *, doublereal *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - doublereal *); - doublereal floatn; - static integer nonneg; - extern /* Subroutine */ int ddawts_(integer *, integer *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *) - ; - extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, - doublereal *, integer *); - integer leniwp; - extern /* Subroutine */ int xerrwd_(char *, integer *, integer *, integer - *, integer *, integer *, integer *, integer *, doublereal *, - doublereal *, ftnlen), dinvwt_(integer *, doublereal *, integer *) - ; - doublereal uround, ypnorm; - - /* Fortran I/O blocks */ - static cilist io___49 = { 0, 6, 0, 0, 0 }; - static cilist io___57 = { 0, 6, 0, 0, 0 }; - static cilist io___59 = { 0, 6, 0, 0, 0 }; - static cilist io___60 = { 0, 6, 0, 0, 0 }; - - - -/* ***BEGIN PROLOGUE DDASPK */ -/* ***DATE WRITTEN 890101 (YYMMDD) */ -/* ***REVISION DATE 910624 (Added HMAX test at 525 in main driver.) */ -/* ***REVISION DATE 920929 (CJ in RES call, RES counter fix.) */ -/* ***REVISION DATE 921215 (Warnings on poor iteration performance) */ -/* ***REVISION DATE 921216 (NRMAX as optional input) */ -/* ***REVISION DATE 930315 (Name change: DDINI to DDINIT) */ -/* ***REVISION DATE 940822 (Replaced initial condition calculation) */ -/* ***REVISION DATE 941101 (Added linesearch in I.C. calculations) */ -/* ***REVISION DATE 941220 (Misc. corrections throughout) */ -/* ***REVISION DATE 950125 (Added DINVWT routine) */ -/* ***REVISION DATE 950714 (Misc. corrections throughout) */ -/* ***REVISION DATE 950802 (Default NRMAX = 5, based on tests.) */ -/* ***REVISION DATE 950808 (Optional error test added.) */ -/* ***REVISION DATE 950814 (Added I.C. constraints and INFO(14)) */ -/* ***REVISION DATE 950828 (Various minor corrections.) */ -/* ***REVISION DATE 951006 (Corrected WT scaling in DFNRMK.) */ -/* ***REVISION DATE 951030 (Corrected history update at end of DDASTP.) */ -/* ***REVISION DATE 960129 (Corrected RL bug in DLINSD, DLINSK.) */ -/* ***REVISION DATE 960301 (Added NONNEG to SAVE statement.) */ -/* ***REVISION DATE 000512 (Removed copyright notices.) */ -/* ***REVISION DATE 000622 (Corrected LWM value using NCPHI.) */ -/* ***REVISION DATE 000628 (Corrected I.C. stopping tests when index = 0.) */ -/* ***REVISION DATE 000628 (Fixed alpha test in I.C. calc., Krylov case.) */ -/* ***REVISION DATE 000628 (Improved restart in I.C. calc., Krylov case.) */ -/* ***REVISION DATE 000628 (Minor corrections throughout.) */ -/* ***REVISION DATE 000711 (Fixed Newton convergence test in DNSD, DNSK.) */ -/* ***REVISION DATE 000712 (Fixed tests on TN - TOUT below 420 and 440.) */ -/* ***CATEGORY NO. I1A2 */ -/* ***KEYWORDS DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS, */ -/* IMPLICIT DIFFERENTIAL SYSTEMS, KRYLOV ITERATION */ -/* ***AUTHORS Linda R. Petzold, Peter N. Brown, Alan C. Hindmarsh, and */ -/* Clement W. Ulrich */ -/* Center for Computational Sciences & Engineering, L-316 */ -/* Lawrence Livermore National Laboratory */ -/* P.O. Box 808, */ -/* Livermore, CA 94551 */ -/* ***PURPOSE This code solves a system of differential/algebraic */ -/* equations of the form */ -/* G(t,y,y') = 0 , */ -/* using a combination of Backward Differentiation Formula */ -/* (BDF) methods and a choice of two linear system solution */ -/* methods: direct (dense or band) or Krylov (iterative). */ -/* This version is in double precision. */ -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* *Usage: */ - -/* IMPLICIT DOUBLE PRECISION(A-H,O-Z) */ -/* INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR(*) */ -/* DOUBLE PRECISION T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), */ -/* RWORK(LRW), RPAR(*) */ -/* EXTERNAL RES, JAC, PSOL */ - -/* CALL DDASPK (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, */ -/* * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL) */ - -/* Quantities which may be altered by the code are: */ -/* T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, IDID, RWORK(*), IWORK(*) */ - - -/* *Arguments: */ - -/* RES:EXT This is the name of a subroutine which you */ -/* provide to define the residual function G(t,y,y') */ -/* of the differential/algebraic system. */ - -/* NEQ:IN This is the number of equations in the system. */ - -/* T:INOUT This is the current value of the independent */ -/* variable. */ - -/* Y(*):INOUT This array contains the solution components at T. */ - -/* YPRIME(*):INOUT This array contains the derivatives of the solution */ -/* components at T. */ - -/* TOUT:IN This is a point at which a solution is desired. */ - -/* INFO(N):IN This is an integer array used to communicate details */ -/* of how the solution is to be carried out, such as */ -/* tolerance type, matrix structure, step size and */ -/* order limits, and choice of nonlinear system method. */ -/* N must be at least 20. */ - -/* RTOL,ATOL:INOUT These quantities represent absolute and relative */ -/* error tolerances (on local error) which you provide */ -/* to indicate how accurately you wish the solution to */ -/* be computed. You may choose them to be both scalars */ -/* or else both arrays of length NEQ. */ - -/* IDID:OUT This integer scalar is an indicator reporting what */ -/* the code did. You must monitor this variable to */ -/* decide what action to take next. */ - -/* RWORK:WORK A real work array of length LRW which provides the */ -/* code with needed storage space. */ - -/* LRW:IN The length of RWORK. */ - -/* IWORK:WORK An integer work array of length LIW which provides */ -/* the code with needed storage space. */ - -/* LIW:IN The length of IWORK. */ - -/* RPAR,IPAR:IN These are real and integer parameter arrays which */ -/* you can use for communication between your calling */ -/* program and the RES, JAC, and PSOL subroutines. */ - -/* JAC:EXT This is the name of a subroutine which you may */ -/* provide (optionally) for calculating Jacobian */ -/* (partial derivative) data involved in solving linear */ -/* systems within DDASPK. */ - -/* PSOL:EXT This is the name of a subroutine which you must */ -/* provide for solving linear systems if you selected */ -/* a Krylov method. The purpose of PSOL is to solve */ -/* linear systems involving a left preconditioner P. */ - -/* *Overview */ - -/* The DDASPK solver uses the backward differentiation formulas of */ -/* orders one through five to solve a system of the form G(t,y,y') = 0 */ -/* for y = Y and y' = YPRIME. Values for Y and YPRIME at the initial */ -/* time must be given as input. These values should be consistent, */ -/* that is, if T, Y, YPRIME are the given initial values, they should */ -/* satisfy G(T,Y,YPRIME) = 0. However, if consistent values are not */ -/* known, in many cases you can have DDASPK solve for them -- see INFO(11). */ -/* (This and other options are described in more detail below.) */ - -/* Normally, DDASPK solves the system from T to TOUT. It is easy to */ -/* continue the solution to get results at additional TOUT. This is */ -/* the interval mode of operation. Intermediate results can also be */ -/* obtained easily by specifying INFO(3). */ - -/* On each step taken by DDASPK, a sequence of nonlinear algebraic */ -/* systems arises. These are solved by one of two types of */ -/* methods: */ -/* * a Newton iteration with a direct method for the linear */ -/* systems involved (INFO(12) = 0), or */ -/* * a Newton iteration with a preconditioned Krylov iterative */ -/* method for the linear systems involved (INFO(12) = 1). */ - -/* The direct method choices are dense and band matrix solvers, */ -/* with either a user-supplied or an internal difference quotient */ -/* Jacobian matrix, as specified by INFO(5) and INFO(6). */ -/* In the band case, INFO(6) = 1, you must supply half-bandwidths */ -/* in IWORK(1) and IWORK(2). */ - -/* The Krylov method is the Generalized Minimum Residual (GMRES) */ -/* method, in either complete or incomplete form, and with */ -/* scaling and preconditioning. The method is implemented */ -/* in an algorithm called SPIGMR. Certain options in the Krylov */ -/* method case are specified by INFO(13) and INFO(15). */ - -/* If the Krylov method is chosen, you may supply a pair of routines, */ -/* JAC and PSOL, to apply preconditioning to the linear system. */ -/* If the system is A*x = b, the matrix is A = dG/dY + CJ*dG/dYPRIME */ -/* (of order NEQ). This system can then be preconditioned in the form */ -/* (P-inverse)*A*x = (P-inverse)*b, with left preconditioner P. */ -/* (DDASPK does not allow right preconditioning.) */ -/* Then the Krylov method is applied to this altered, but equivalent, */ -/* linear system, hopefully with much better performance than without */ -/* preconditioning. (In addition, a diagonal scaling matrix based on */ -/* the tolerances is also introduced into the altered system.) */ - -/* The JAC routine evaluates any data needed for solving systems */ -/* with coefficient matrix P, and PSOL carries out that solution. */ -/* In any case, in order to improve convergence, you should try to */ -/* make P approximate the matrix A as much as possible, while keeping */ -/* the system P*x = b reasonably easy and inexpensive to solve for x, */ -/* given a vector b. */ - - -/* *Description */ - -/* ------INPUT - WHAT TO DO ON THE FIRST CALL TO DDASPK------------------- */ - - -/* The first call of the code is defined to be the start of each new */ -/* problem. Read through the descriptions of all the following items, */ -/* provide sufficient storage space for designated arrays, set */ -/* appropriate variables for the initialization of the problem, and */ -/* give information about how you want the problem to be solved. */ - - -/* RES -- Provide a subroutine of the form */ - -/* SUBROUTINE RES (T, Y, YPRIME, CJ, DELTA, IRES, RPAR, IPAR) */ - -/* to define the system of differential/algebraic */ -/* equations which is to be solved. For the given values */ -/* of T, Y and YPRIME, the subroutine should return */ -/* the residual of the differential/algebraic system */ -/* DELTA = G(T,Y,YPRIME) */ -/* DELTA is a vector of length NEQ which is output from RES. */ - -/* Subroutine RES must not alter T, Y, YPRIME, or CJ. */ -/* You must declare the name RES in an EXTERNAL */ -/* statement in your program that calls DDASPK. */ -/* You must dimension Y, YPRIME, and DELTA in RES. */ - -/* The input argument CJ can be ignored, or used to rescale */ -/* constraint equations in the system (see Ref. 2, p. 145). */ -/* Note: In this respect, DDASPK is not downward-compatible */ -/* with DDASSL, which does not have the RES argument CJ. */ - -/* IRES is an integer flag which is always equal to zero */ -/* on input. Subroutine RES should alter IRES only if it */ -/* encounters an illegal value of Y or a stop condition. */ -/* Set IRES = -1 if an input value is illegal, and DDASPK */ -/* will try to solve the problem without getting IRES = -1. */ -/* If IRES = -2, DDASPK will return control to the calling */ -/* program with IDID = -11. */ - -/* RPAR and IPAR are real and integer parameter arrays which */ -/* you can use for communication between your calling program */ -/* and subroutine RES. They are not altered by DDASPK. If you */ -/* do not need RPAR or IPAR, ignore these parameters by treat- */ -/* ing them as dummy arguments. If you do choose to use them, */ -/* dimension them in your calling program and in RES as arrays */ -/* of appropriate length. */ - -/* NEQ -- Set it to the number of equations in the system (NEQ .GE. 1). */ - -/* T -- Set it to the initial point of the integration. (T must be */ -/* a variable.) */ - -/* Y(*) -- Set this array to the initial values of the NEQ solution */ -/* components at the initial point. You must dimension Y of */ -/* length at least NEQ in your calling program. */ - -/* YPRIME(*) -- Set this array to the initial values of the NEQ first */ -/* derivatives of the solution components at the initial */ -/* point. You must dimension YPRIME at least NEQ in your */ -/* calling program. */ - -/* TOUT - Set it to the first point at which a solution is desired. */ -/* You cannot take TOUT = T. Integration either forward in T */ -/* (TOUT .GT. T) or backward in T (TOUT .LT. T) is permitted. */ - -/* The code advances the solution from T to TOUT using step */ -/* sizes which are automatically selected so as to achieve the */ -/* desired accuracy. If you wish, the code will return with the */ -/* solution and its derivative at intermediate steps (the */ -/* intermediate-output mode) so that you can monitor them, */ -/* but you still must provide TOUT in accord with the basic */ -/* aim of the code. */ - -/* The first step taken by the code is a critical one because */ -/* it must reflect how fast the solution changes near the */ -/* initial point. The code automatically selects an initial */ -/* step size which is practically always suitable for the */ -/* problem. By using the fact that the code will not step past */ -/* TOUT in the first step, you could, if necessary, restrict the */ -/* length of the initial step. */ - -/* For some problems it may not be permissible to integrate */ -/* past a point TSTOP, because a discontinuity occurs there */ -/* or the solution or its derivative is not defined beyond */ -/* TSTOP. When you have declared a TSTOP point (see INFO(4) */ -/* and RWORK(1)), you have told the code not to integrate past */ -/* TSTOP. In this case any tout beyond TSTOP is invalid input. */ - -/* INFO(*) - Use the INFO array to give the code more details about */ -/* how you want your problem solved. This array should be */ -/* dimensioned of length 20, though DDASPK uses only the */ -/* first 15 entries. You must respond to all of the following */ -/* items, which are arranged as questions. The simplest use */ -/* of DDASPK corresponds to setting all entries of INFO to 0. */ - -/* INFO(1) - This parameter enables the code to initialize itself. */ -/* You must set it to indicate the start of every new */ -/* problem. */ - -/* **** Is this the first call for this problem ... */ -/* yes - set INFO(1) = 0 */ -/* no - not applicable here. */ -/* See below for continuation calls. **** */ - -/* INFO(2) - How much accuracy you want of your solution */ -/* is specified by the error tolerances RTOL and ATOL. */ -/* The simplest use is to take them both to be scalars. */ -/* To obtain more flexibility, they can both be arrays. */ -/* The code must be told your choice. */ - -/* **** Are both error tolerances RTOL, ATOL scalars ... */ -/* yes - set INFO(2) = 0 */ -/* and input scalars for both RTOL and ATOL */ -/* no - set INFO(2) = 1 */ -/* and input arrays for both RTOL and ATOL **** */ - -/* INFO(3) - The code integrates from T in the direction of TOUT */ -/* by steps. If you wish, it will return the computed */ -/* solution and derivative at the next intermediate step */ -/* (the intermediate-output mode) or TOUT, whichever comes */ -/* first. This is a good way to proceed if you want to */ -/* see the behavior of the solution. If you must have */ -/* solutions at a great many specific TOUT points, this */ -/* code will compute them efficiently. */ - -/* **** Do you want the solution only at */ -/* TOUT (and not at the next intermediate step) ... */ -/* yes - set INFO(3) = 0 */ -/* no - set INFO(3) = 1 **** */ - -/* INFO(4) - To handle solutions at a great many specific */ -/* values TOUT efficiently, this code may integrate past */ -/* TOUT and interpolate to obtain the result at TOUT. */ -/* Sometimes it is not possible to integrate beyond some */ -/* point TSTOP because the equation changes there or it is */ -/* not defined past TSTOP. Then you must tell the code */ -/* this stop condition. */ - -/* **** Can the integration be carried out without any */ -/* restrictions on the independent variable T ... */ -/* yes - set INFO(4) = 0 */ -/* no - set INFO(4) = 1 */ -/* and define the stopping point TSTOP by */ -/* setting RWORK(1) = TSTOP **** */ - -/* INFO(5) - used only when INFO(12) = 0 (direct methods). */ -/* To solve differential/algebraic systems you may wish */ -/* to use a matrix of partial derivatives of the */ -/* system of differential equations. If you do not */ -/* provide a subroutine to evaluate it analytically (see */ -/* description of the item JAC in the call list), it will */ -/* be approximated by numerical differencing in this code. */ -/* Although it is less trouble for you to have the code */ -/* compute partial derivatives by numerical differencing, */ -/* the solution will be more reliable if you provide the */ -/* derivatives via JAC. Usually numerical differencing is */ -/* more costly than evaluating derivatives in JAC, but */ -/* sometimes it is not - this depends on your problem. */ - -/* **** Do you want the code to evaluate the partial deriv- */ -/* atives automatically by numerical differences ... */ -/* yes - set INFO(5) = 0 */ -/* no - set INFO(5) = 1 */ -/* and provide subroutine JAC for evaluating the */ -/* matrix of partial derivatives **** */ - -/* INFO(6) - used only when INFO(12) = 0 (direct methods). */ -/* DDASPK will perform much better if the matrix of */ -/* partial derivatives, dG/dY + CJ*dG/dYPRIME (here CJ is */ -/* a scalar determined by DDASPK), is banded and the code */ -/* is told this. In this case, the storage needed will be */ -/* greatly reduced, numerical differencing will be performed */ -/* much cheaper, and a number of important algorithms will */ -/* execute much faster. The differential equation is said */ -/* to have half-bandwidths ML (lower) and MU (upper) if */ -/* equation i involves only unknowns Y(j) with */ -/* i-ML .le. j .le. i+MU . */ -/* For all i=1,2,...,NEQ. Thus, ML and MU are the widths */ -/* of the lower and upper parts of the band, respectively, */ -/* with the main diagonal being excluded. If you do not */ -/* indicate that the equation has a banded matrix of partial */ -/* derivatives the code works with a full matrix of NEQ**2 */ -/* elements (stored in the conventional way). Computations */ -/* with banded matrices cost less time and storage than with */ -/* full matrices if 2*ML+MU .lt. NEQ. If you tell the */ -/* code that the matrix of partial derivatives has a banded */ -/* structure and you want to provide subroutine JAC to */ -/* compute the partial derivatives, then you must be careful */ -/* to store the elements of the matrix in the special form */ -/* indicated in the description of JAC. */ - -/* **** Do you want to solve the problem using a full (dense) */ -/* matrix (and not a special banded structure) ... */ -/* yes - set INFO(6) = 0 */ -/* no - set INFO(6) = 1 */ -/* and provide the lower (ML) and upper (MU) */ -/* bandwidths by setting */ -/* IWORK(1)=ML */ -/* IWORK(2)=MU **** */ - -/* INFO(7) - You can specify a maximum (absolute value of) */ -/* stepsize, so that the code will avoid passing over very */ -/* large regions. */ - -/* **** Do you want the code to decide on its own the maximum */ -/* stepsize ... */ -/* yes - set INFO(7) = 0 */ -/* no - set INFO(7) = 1 */ -/* and define HMAX by setting */ -/* RWORK(2) = HMAX **** */ - -/* INFO(8) - Differential/algebraic problems may occasionally */ -/* suffer from severe scaling difficulties on the first */ -/* step. If you know a great deal about the scaling of */ -/* your problem, you can help to alleviate this problem */ -/* by specifying an initial stepsize H0. */ - -/* **** Do you want the code to define its own initial */ -/* stepsize ... */ -/* yes - set INFO(8) = 0 */ -/* no - set INFO(8) = 1 */ -/* and define H0 by setting */ -/* RWORK(3) = H0 **** */ - -/* INFO(9) - If storage is a severe problem, you can save some */ -/* storage by restricting the maximum method order MAXORD. */ -/* The default value is 5. For each order decrease below 5, */ -/* the code requires NEQ fewer locations, but it is likely */ -/* to be slower. In any case, you must have */ -/* 1 .le. MAXORD .le. 5. */ -/* **** Do you want the maximum order to default to 5 ... */ -/* yes - set INFO(9) = 0 */ -/* no - set INFO(9) = 1 */ -/* and define MAXORD by setting */ -/* IWORK(3) = MAXORD **** */ - -/* INFO(10) - If you know that certain components of the */ -/* solutions to your equations are always nonnegative */ -/* (or nonpositive), it may help to set this */ -/* parameter. There are three options that are */ -/* available: */ -/* 1. To have constraint checking only in the initial */ -/* condition calculation. */ -/* 2. To enforce nonnegativity in Y during the integration. */ -/* 3. To enforce both options 1 and 2. */ - -/* When selecting option 2 or 3, it is probably best to try the */ -/* code without using this option first, and only use */ -/* this option if that does not work very well. */ - -/* **** Do you want the code to solve the problem without */ -/* invoking any special inequality constraints ... */ -/* yes - set INFO(10) = 0 */ -/* no - set INFO(10) = 1 to have option 1 enforced */ -/* no - set INFO(10) = 2 to have option 2 enforced */ -/* no - set INFO(10) = 3 to have option 3 enforced **** */ - -/* If you have specified INFO(10) = 1 or 3, then you */ -/* will also need to identify how each component of Y */ -/* in the initial condition calculation is constrained. */ -/* You must set: */ -/* IWORK(40+I) = +1 if Y(I) must be .GE. 0, */ -/* IWORK(40+I) = +2 if Y(I) must be .GT. 0, */ -/* IWORK(40+I) = -1 if Y(I) must be .LE. 0, while */ -/* IWORK(40+I) = -2 if Y(I) must be .LT. 0, while */ -/* IWORK(40+I) = 0 if Y(I) is not constrained. */ - -/* INFO(11) - DDASPK normally requires the initial T, Y, and */ -/* YPRIME to be consistent. That is, you must have */ -/* G(T,Y,YPRIME) = 0 at the initial T. If you do not know */ -/* the initial conditions precisely, in some cases */ -/* DDASPK may be able to compute it. */ - -/* Denoting the differential variables in Y by Y_d */ -/* and the algebraic variables by Y_a, DDASPK can solve */ -/* one of two initialization problems: */ -/* 1. Given Y_d, calculate Y_a and Y'_d, or */ -/* 2. Given Y', calculate Y. */ -/* In either case, initial values for the given */ -/* components are input, and initial guesses for */ -/* the unknown components must also be provided as input. */ - -/* **** Are the initial T, Y, YPRIME consistent ... */ - -/* yes - set INFO(11) = 0 */ -/* no - set INFO(11) = 1 to calculate option 1 above, */ -/* or set INFO(11) = 2 to calculate option 2 **** */ - -/* If you have specified INFO(11) = 1, then you */ -/* will also need to identify which are the */ -/* differential and which are the algebraic */ -/* components (algebraic components are components */ -/* whose derivatives do not appear explicitly */ -/* in the function G(T,Y,YPRIME)). You must set: */ -/* IWORK(LID+I) = +1 if Y(I) is a differential variable */ -/* IWORK(LID+I) = -1 if Y(I) is an algebraic variable, */ -/* where LID = 40 if INFO(10) = 0 or 2 and LID = 40+NEQ */ -/* if INFO(10) = 1 or 3. */ - -/* INFO(12) - Except for the addition of the RES argument CJ, */ -/* DDASPK by default is downward-compatible with DDASSL, */ -/* which uses only direct (dense or band) methods to solve */ -/* the linear systems involved. You must set INFO(12) to */ -/* indicate whether you want the direct methods or the */ -/* Krylov iterative method. */ -/* **** Do you want DDASPK to use standard direct methods */ -/* (dense or band) or the Krylov (iterative) method ... */ -/* direct methods - set INFO(12) = 0. */ -/* Krylov method - set INFO(12) = 1, */ -/* and check the settings of INFO(13) and INFO(15). */ - -/* INFO(13) - used when INFO(12) = 1 (Krylov methods). */ -/* DDASPK uses scalars MAXL, KMP, NRMAX, and EPLI for the */ -/* iterative solution of linear systems. INFO(13) allows */ -/* you to override the default values of these parameters. */ -/* These parameters and their defaults are as follows: */ -/* MAXL = maximum number of iterations in the SPIGMR */ -/* algorithm (MAXL .le. NEQ). The default is */ -/* MAXL = MIN(5,NEQ). */ -/* KMP = number of vectors on which orthogonalization is */ -/* done in the SPIGMR algorithm. The default is */ -/* KMP = MAXL, which corresponds to complete GMRES */ -/* iteration, as opposed to the incomplete form. */ -/* NRMAX = maximum number of restarts of the SPIGMR */ -/* algorithm per nonlinear iteration. The default is */ -/* NRMAX = 5. */ -/* EPLI = convergence test constant in SPIGMR algorithm. */ -/* The default is EPLI = 0.05. */ -/* Note that the length of RWORK depends on both MAXL */ -/* and KMP. See the definition of LRW below. */ -/* **** Are MAXL, KMP, and EPLI to be given their */ -/* default values ... */ -/* yes - set INFO(13) = 0 */ -/* no - set INFO(13) = 1, */ -/* and set all of the following: */ -/* IWORK(24) = MAXL (1 .le. MAXL .le. NEQ) */ -/* IWORK(25) = KMP (1 .le. KMP .le. MAXL) */ -/* IWORK(26) = NRMAX (NRMAX .ge. 0) */ -/* RWORK(10) = EPLI (0 .lt. EPLI .lt. 1.0) **** */ - -/* INFO(14) - used with INFO(11) > 0 (initial condition */ -/* calculation is requested). In this case, you may */ -/* request control to be returned to the calling program */ -/* immediately after the initial condition calculation, */ -/* before proceeding to the integration of the system */ -/* (e.g. to examine the computed Y and YPRIME). */ -/* If this is done, and if the initialization succeeded */ -/* (IDID = 4), you should reset INFO(11) to 0 for the */ -/* next call, to prevent the solver from repeating the */ -/* initialization (and to avoid an infinite loop). */ -/* **** Do you want to proceed to the integration after */ -/* the initial condition calculation is done ... */ -/* yes - set INFO(14) = 0 */ -/* no - set INFO(14) = 1 **** */ - -/* INFO(15) - used when INFO(12) = 1 (Krylov methods). */ -/* When using preconditioning in the Krylov method, */ -/* you must supply a subroutine, PSOL, which solves the */ -/* associated linear systems using P. */ -/* The usage of DDASPK is simpler if PSOL can carry out */ -/* the solution without any prior calculation of data. */ -/* However, if some partial derivative data is to be */ -/* calculated in advance and used repeatedly in PSOL, */ -/* then you must supply a JAC routine to do this, */ -/* and set INFO(15) to indicate that JAC is to be called */ -/* for this purpose. For example, P might be an */ -/* approximation to a part of the matrix A which can be */ -/* calculated and LU-factored for repeated solutions of */ -/* the preconditioner system. The arrays WP and IWP */ -/* (described under JAC and PSOL) can be used to */ -/* communicate data between JAC and PSOL. */ -/* **** Does PSOL operate with no prior preparation ... */ -/* yes - set INFO(15) = 0 (no JAC routine) */ -/* no - set INFO(15) = 1 */ -/* and supply a JAC routine to evaluate and */ -/* preprocess any required Jacobian data. **** */ - -/* INFO(16) - option to exclude algebraic variables from */ -/* the error test. */ -/* **** Do you wish to control errors locally on */ -/* all the variables... */ -/* yes - set INFO(16) = 0 */ -/* no - set INFO(16) = 1 */ -/* If you have specified INFO(16) = 1, then you */ -/* will also need to identify which are the */ -/* differential and which are the algebraic */ -/* components (algebraic components are components */ -/* whose derivatives do not appear explicitly */ -/* in the function G(T,Y,YPRIME)). You must set: */ -/* IWORK(LID+I) = +1 if Y(I) is a differential */ -/* variable, and */ -/* IWORK(LID+I) = -1 if Y(I) is an algebraic */ -/* variable, */ -/* where LID = 40 if INFO(10) = 0 or 2 and */ -/* LID = 40 + NEQ if INFO(10) = 1 or 3. */ - -/* INFO(17) - used when INFO(11) > 0 (DDASPK is to do an */ -/* initial condition calculation). */ -/* DDASPK uses several heuristic control quantities in the */ -/* initial condition calculation. They have default values, */ -/* but can also be set by the user using INFO(17). */ -/* These parameters and their defaults are as follows: */ -/* MXNIT = maximum number of Newton iterations */ -/* per Jacobian or preconditioner evaluation. */ -/* The default is: */ -/* MXNIT = 5 in the direct case (INFO(12) = 0), and */ -/* MXNIT = 15 in the Krylov case (INFO(12) = 1). */ -/* MXNJ = maximum number of Jacobian or preconditioner */ -/* evaluations. The default is: */ -/* MXNJ = 6 in the direct case (INFO(12) = 0), and */ -/* MXNJ = 2 in the Krylov case (INFO(12) = 1). */ -/* MXNH = maximum number of values of the artificial */ -/* stepsize parameter H to be tried if INFO(11) = 1. */ -/* The default is MXNH = 5. */ -/* NOTE: the maximum number of Newton iterations */ -/* allowed in all is MXNIT*MXNJ*MXNH if INFO(11) = 1, */ -/* and MXNIT*MXNJ if INFO(11) = 2. */ -/* LSOFF = flag to turn off the linesearch algorithm */ -/* (LSOFF = 0 means linesearch is on, LSOFF = 1 means */ -/* it is turned off). The default is LSOFF = 0. */ -/* STPTOL = minimum scaled step in linesearch algorithm. */ -/* The default is STPTOL = (unit roundoff)**(2/3). */ -/* EPINIT = swing factor in the Newton iteration convergence */ -/* test. The test is applied to the residual vector, */ -/* premultiplied by the approximate Jacobian (in the */ -/* direct case) or the preconditioner (in the Krylov */ -/* case). For convergence, the weighted RMS norm of */ -/* this vector (scaled by the error weights) must be */ -/* less than EPINIT*EPCON, where EPCON = .33 is the */ -/* analogous test constant used in the time steps. */ -/* The default is EPINIT = .01. */ -/* **** Are the initial condition heuristic controls to be */ -/* given their default values... */ -/* yes - set INFO(17) = 0 */ -/* no - set INFO(17) = 1, */ -/* and set all of the following: */ -/* IWORK(32) = MXNIT (.GT. 0) */ -/* IWORK(33) = MXNJ (.GT. 0) */ -/* IWORK(34) = MXNH (.GT. 0) */ -/* IWORK(35) = LSOFF ( = 0 or 1) */ -/* RWORK(14) = STPTOL (.GT. 0.0) */ -/* RWORK(15) = EPINIT (.GT. 0.0) **** */ - -/* INFO(18) - option to get extra printing in initial condition */ -/* calculation. */ -/* **** Do you wish to have extra printing... */ -/* no - set INFO(18) = 0 */ -/* yes - set INFO(18) = 1 for minimal printing, or */ -/* set INFO(18) = 2 for full printing. */ -/* If you have specified INFO(18) .ge. 1, data */ -/* will be printed with the error handler routines. */ -/* To print to a non-default unit number L, include */ -/* the line CALL XSETUN(L) in your program. **** */ - -/* RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) */ -/* error tolerances to tell the code how accurately you */ -/* want the solution to be computed. They must be defined */ -/* as variables because the code may change them. */ -/* you have two choices -- */ -/* Both RTOL and ATOL are scalars (INFO(2) = 0), or */ -/* both RTOL and ATOL are vectors (INFO(2) = 1). */ -/* In either case all components must be non-negative. */ - -/* The tolerances are used by the code in a local error */ -/* test at each step which requires roughly that */ -/* abs(local error in Y(i)) .le. EWT(i) , */ -/* where EWT(i) = RTOL*abs(Y(i)) + ATOL is an error weight */ -/* quantity, for each vector component. */ -/* (More specifically, a root-mean-square norm is used to */ -/* measure the size of vectors, and the error test uses the */ -/* magnitude of the solution at the beginning of the step.) */ - -/* The true (global) error is the difference between the */ -/* true solution of the initial value problem and the */ -/* computed approximation. Practically all present day */ -/* codes, including this one, control the local error at */ -/* each step and do not even attempt to control the global */ -/* error directly. */ - -/* Usually, but not always, the true accuracy of */ -/* the computed Y is comparable to the error tolerances. */ -/* This code will usually, but not always, deliver a more */ -/* accurate solution if you reduce the tolerances and */ -/* integrate again. By comparing two such solutions you */ -/* can get a fairly reliable idea of the true error in the */ -/* solution at the larger tolerances. */ - -/* Setting ATOL = 0. results in a pure relative error test */ -/* on that component. Setting RTOL = 0. results in a pure */ -/* absolute error test on that component. A mixed test */ -/* with non-zero RTOL and ATOL corresponds roughly to a */ -/* relative error test when the solution component is */ -/* much bigger than ATOL and to an absolute error test */ -/* when the solution component is smaller than the */ -/* threshold ATOL. */ - -/* The code will not attempt to compute a solution at an */ -/* accuracy unreasonable for the machine being used. It */ -/* will advise you if you ask for too much accuracy and */ -/* inform you as to the maximum accuracy it believes */ -/* possible. */ - -/* RWORK(*) -- a real work array, which should be dimensioned in your */ -/* calling program with a length equal to the value of */ -/* LRW (or greater). */ - -/* LRW -- Set it to the declared length of the RWORK array. The */ -/* minimum length depends on the options you have selected, */ -/* given by a base value plus additional storage as described */ -/* below. */ - -/* If INFO(12) = 0 (standard direct method), the base value is */ -/* base = 50 + max(MAXORD+4,7)*NEQ. */ -/* The default value is MAXORD = 5 (see INFO(9)). With the */ -/* default MAXORD, base = 50 + 9*NEQ. */ -/* Additional storage must be added to the base value for */ -/* any or all of the following options: */ -/* if INFO(6) = 0 (dense matrix), add NEQ**2 */ -/* if INFO(6) = 1 (banded matrix), then */ -/* if INFO(5) = 0, add (2*ML+MU+1)*NEQ + 2*(NEQ/(ML+MU+1)+1), */ -/* if INFO(5) = 1, add (2*ML+MU+1)*NEQ, */ -/* if INFO(16) = 1, add NEQ. */ - -/* If INFO(12) = 1 (Krylov method), the base value is */ -/* base = 50 + (MAXORD+5)*NEQ + (MAXL+3+MIN0(1,MAXL-KMP))*NEQ + */ -/* + (MAXL+3)*MAXL + 1 + LENWP. */ -/* See PSOL for description of LENWP. The default values are: */ -/* MAXORD = 5 (see INFO(9)), MAXL = min(5,NEQ) and KMP = MAXL */ -/* (see INFO(13)). */ -/* With the default values for MAXORD, MAXL and KMP, */ -/* base = 91 + 18*NEQ + LENWP. */ -/* Additional storage must be added to the base value for */ -/* any or all of the following options: */ -/* if INFO(16) = 1, add NEQ. */ - - -/* IWORK(*) -- an integer work array, which should be dimensioned in */ -/* your calling program with a length equal to the value */ -/* of LIW (or greater). */ - -/* LIW -- Set it to the declared length of the IWORK array. The */ -/* minimum length depends on the options you have selected, */ -/* given by a base value plus additional storage as described */ -/* below. */ - -/* If INFO(12) = 0 (standard direct method), the base value is */ -/* base = 40 + NEQ. */ -/* IF INFO(10) = 1 or 3, add NEQ to the base value. */ -/* If INFO(11) = 1 or INFO(16) =1, add NEQ to the base value. */ - -/* If INFO(12) = 1 (Krylov method), the base value is */ -/* base = 40 + LENIWP. */ -/* See PSOL for description of LENIWP. */ -/* IF INFO(10) = 1 or 3, add NEQ to the base value. */ -/* If INFO(11) = 1 or INFO(16) = 1, add NEQ to the base value. */ - - -/* RPAR, IPAR -- These are arrays of double precision and integer type, */ -/* respectively, which are available for you to use */ -/* for communication between your program that calls */ -/* DDASPK and the RES subroutine (and the JAC and PSOL */ -/* subroutines). They are not altered by DDASPK. */ -/* If you do not need RPAR or IPAR, ignore these */ -/* parameters by treating them as dummy arguments. */ -/* If you do choose to use them, dimension them in */ -/* your calling program and in RES (and in JAC and PSOL) */ -/* as arrays of appropriate length. */ - -/* JAC -- This is the name of a routine that you may supply */ -/* (optionally) that relates to the Jacobian matrix of the */ -/* nonlinear system that the code must solve at each T step. */ -/* The role of JAC (and its call sequence) depends on whether */ -/* a direct (INFO(12) = 0) or Krylov (INFO(12) = 1) method */ -/* is selected. */ - -/* **** INFO(12) = 0 (direct methods): */ -/* If you are letting the code generate partial derivatives */ -/* numerically (INFO(5) = 0), then JAC can be absent */ -/* (or perhaps a dummy routine to satisfy the loader). */ -/* Otherwise you must supply a JAC routine to compute */ -/* the matrix A = dG/dY + CJ*dG/dYPRIME. It must have */ -/* the form */ - -/* SUBROUTINE JAC (T, Y, YPRIME, PD, CJ, RPAR, IPAR) */ - -/* The JAC routine must dimension Y, YPRIME, and PD (and RPAR */ -/* and IPAR if used). CJ is a scalar which is input to JAC. */ -/* For the given values of T, Y, and YPRIME, the JAC routine */ -/* must evaluate the nonzero elements of the matrix A, and */ -/* store these values in the array PD. The elements of PD are */ -/* set to zero before each call to JAC, so that only nonzero */ -/* elements need to be defined. */ -/* The way you store the elements into the PD array depends */ -/* on the structure of the matrix indicated by INFO(6). */ -/* *** INFO(6) = 0 (full or dense matrix) *** */ -/* Give PD a first dimension of NEQ. When you evaluate the */ -/* nonzero partial derivatives of equation i (i.e. of G(i)) */ -/* with respect to component j (of Y and YPRIME), you must */ -/* store the element in PD according to */ -/* PD(i,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). */ -/* *** INFO(6) = 1 (banded matrix with half-bandwidths ML, MU */ -/* as described under INFO(6)) *** */ -/* Give PD a first dimension of 2*ML+MU+1. When you */ -/* evaluate the nonzero partial derivatives of equation i */ -/* (i.e. of G(i)) with respect to component j (of Y and */ -/* YPRIME), you must store the element in PD according to */ -/* IROW = i - j + ML + MU + 1 */ -/* PD(IROW,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). */ - -/* **** INFO(12) = 1 (Krylov method): */ -/* If you are not calculating Jacobian data in advance for use */ -/* in PSOL (INFO(15) = 0), JAC can be absent (or perhaps a */ -/* dummy routine to satisfy the loader). Otherwise, you may */ -/* supply a JAC routine to compute and preprocess any parts of */ -/* of the Jacobian matrix A = dG/dY + CJ*dG/dYPRIME that are */ -/* involved in the preconditioner matrix P. */ -/* It is to have the form */ - -/* SUBROUTINE JAC (RES, IRES, NEQ, T, Y, YPRIME, REWT, SAVR, */ -/* WK, H, CJ, WP, IWP, IER, RPAR, IPAR) */ - -/* The JAC routine must dimension Y, YPRIME, REWT, SAVR, WK, */ -/* and (if used) WP, IWP, RPAR, and IPAR. */ -/* The Y, YPRIME, and SAVR arrays contain the current values */ -/* of Y, YPRIME, and the residual G, respectively. */ -/* The array WK is work space of length NEQ. */ -/* H is the step size. CJ is a scalar, input to JAC, that is */ -/* normally proportional to 1/H. REWT is an array of */ -/* reciprocal error weights, 1/EWT(i), where EWT(i) is */ -/* RTOL*abs(Y(i)) + ATOL (unless you supplied routine DDAWTS */ -/* instead), for use in JAC if needed. For example, if JAC */ -/* computes difference quotient approximations to partial */ -/* derivatives, the REWT array may be useful in setting the */ -/* increments used. The JAC routine should do any */ -/* factorization operations called for, in preparation for */ -/* solving linear systems in PSOL. The matrix P should */ -/* be an approximation to the Jacobian, */ -/* A = dG/dY + CJ*dG/dYPRIME. */ - -/* WP and IWP are real and integer work arrays which you may */ -/* use for communication between your JAC routine and your */ -/* PSOL routine. These may be used to store elements of the */ -/* preconditioner P, or related matrix data (such as factored */ -/* forms). They are not altered by DDASPK. */ -/* If you do not need WP or IWP, ignore these parameters by */ -/* treating them as dummy arguments. If you do use them, */ -/* dimension them appropriately in your JAC and PSOL routines. */ -/* See the PSOL description for instructions on setting */ -/* the lengths of WP and IWP. */ - -/* On return, JAC should set the error flag IER as follows.. */ -/* IER = 0 if JAC was successful, */ -/* IER .ne. 0 if JAC was unsuccessful (e.g. if Y or YPRIME */ -/* was illegal, or a singular matrix is found). */ -/* (If IER .ne. 0, a smaller stepsize will be tried.) */ -/* IER = 0 on entry to JAC, so need be reset only on a failure. */ -/* If RES is used within JAC, then a nonzero value of IRES will */ -/* override any nonzero value of IER (see the RES description). */ - -/* Regardless of the method type, subroutine JAC must not */ -/* alter T, Y(*), YPRIME(*), H, CJ, or REWT(*). */ -/* You must declare the name JAC in an EXTERNAL statement in */ -/* your program that calls DDASPK. */ - -/* PSOL -- This is the name of a routine you must supply if you have */ -/* selected a Krylov method (INFO(12) = 1) with preconditioning. */ -/* In the direct case (INFO(12) = 0), PSOL can be absent */ -/* (a dummy routine may have to be supplied to satisfy the */ -/* loader). Otherwise, you must provide a PSOL routine to */ -/* solve linear systems arising from preconditioning. */ -/* When supplied with INFO(12) = 1, the PSOL routine is to */ -/* have the form */ - -/* SUBROUTINE PSOL (NEQ, T, Y, YPRIME, SAVR, WK, CJ, WGHT, */ -/* WP, IWP, B, EPLIN, IER, RPAR, IPAR) */ - -/* The PSOL routine must solve linear systems of the form */ -/* P*x = b where P is the left preconditioner matrix. */ - -/* The right-hand side vector b is in the B array on input, and */ -/* PSOL must return the solution vector x in B. */ -/* The Y, YPRIME, and SAVR arrays contain the current values */ -/* of Y, YPRIME, and the residual G, respectively. */ - -/* Work space required by JAC and/or PSOL, and space for data to */ -/* be communicated from JAC to PSOL is made available in the form */ -/* of arrays WP and IWP, which are parts of the RWORK and IWORK */ -/* arrays, respectively. The lengths of these real and integer */ -/* work spaces WP and IWP must be supplied in LENWP and LENIWP, */ -/* respectively, as follows.. */ -/* IWORK(27) = LENWP = length of real work space WP */ -/* IWORK(28) = LENIWP = length of integer work space IWP. */ - -/* WK is a work array of length NEQ for use by PSOL. */ -/* CJ is a scalar, input to PSOL, that is normally proportional */ -/* to 1/H (H = stepsize). If the old value of CJ */ -/* (at the time of the last JAC call) is needed, it must have */ -/* been saved by JAC in WP. */ - -/* WGHT is an array of weights, to be used if PSOL uses an */ -/* iterative method and performs a convergence test. (In terms */ -/* of the argument REWT to JAC, WGHT is REWT/sqrt(NEQ).) */ -/* If PSOL uses an iterative method, it should use EPLIN */ -/* (a heuristic parameter) as the bound on the weighted norm of */ -/* the residual for the computed solution. Specifically, the */ -/* residual vector R should satisfy */ -/* SQRT (SUM ( (R(i)*WGHT(i))**2 ) ) .le. EPLIN */ - -/* PSOL must not alter NEQ, T, Y, YPRIME, SAVR, CJ, WGHT, EPLIN. */ - -/* On return, PSOL should set the error flag IER as follows.. */ -/* IER = 0 if PSOL was successful, */ -/* IER .lt. 0 if an unrecoverable error occurred, meaning */ -/* control will be passed to the calling routine, */ -/* IER .gt. 0 if a recoverable error occurred, meaning that */ -/* the step will be retried with the same step size */ -/* but with a call to JAC to update necessary data, */ -/* unless the Jacobian data is current, in which case */ -/* the step will be retried with a smaller step size. */ -/* IER = 0 on entry to PSOL so need be reset only on a failure. */ - -/* You must declare the name PSOL in an EXTERNAL statement in */ -/* your program that calls DDASPK. */ - - -/* OPTIONALLY REPLACEABLE SUBROUTINE: */ - -/* DDASPK uses a weighted root-mean-square norm to measure the */ -/* size of various error vectors. The weights used in this norm */ -/* are set in the following subroutine: */ - -/* SUBROUTINE DDAWTS (NEQ, IWT, RTOL, ATOL, Y, EWT, RPAR, IPAR) */ -/* DIMENSION RTOL(*), ATOL(*), Y(*), EWT(*), RPAR(*), IPAR(*) */ - -/* A DDAWTS routine has been included with DDASPK which sets the */ -/* weights according to */ -/* EWT(I) = RTOL*ABS(Y(I)) + ATOL */ -/* in the case of scalar tolerances (IWT = 0) or */ -/* EWT(I) = RTOL(I)*ABS(Y(I)) + ATOL(I) */ -/* in the case of array tolerances (IWT = 1). (IWT is INFO(2).) */ -/* In some special cases, it may be appropriate for you to define */ -/* your own error weights by writing a subroutine DDAWTS to be */ -/* called instead of the version supplied. However, this should */ -/* be attempted only after careful thought and consideration. */ -/* If you supply this routine, you may use the tolerances and Y */ -/* as appropriate, but do not overwrite these variables. You */ -/* may also use RPAR and IPAR to communicate data as appropriate. */ -/* ***Note: Aside from the values of the weights, the choice of */ -/* norm used in DDASPK (weighted root-mean-square) is not subject */ -/* to replacement by the user. In this respect, DDASPK is not */ -/* downward-compatible with the original DDASSL solver (in which */ -/* the norm routine was optionally user-replaceable). */ - - -/* ------OUTPUT - AFTER ANY RETURN FROM DDASPK---------------------------- */ - -/* The principal aim of the code is to return a computed solution at */ -/* T = TOUT, although it is also possible to obtain intermediate */ -/* results along the way. To find out whether the code achieved its */ -/* goal or if the integration process was interrupted before the task */ -/* was completed, you must check the IDID parameter. */ - - -/* T -- The output value of T is the point to which the solution */ -/* was successfully advanced. */ - -/* Y(*) -- contains the computed solution approximation at T. */ - -/* YPRIME(*) -- contains the computed derivative approximation at T. */ - -/* IDID -- reports what the code did, described as follows: */ - -/* *** TASK COMPLETED *** */ -/* Reported by positive values of IDID */ - -/* IDID = 1 -- a step was successfully taken in the */ -/* intermediate-output mode. The code has not */ -/* yet reached TOUT. */ - -/* IDID = 2 -- the integration to TSTOP was successfully */ -/* completed (T = TSTOP) by stepping exactly to TSTOP. */ - -/* IDID = 3 -- the integration to TOUT was successfully */ -/* completed (T = TOUT) by stepping past TOUT. */ -/* Y(*) and YPRIME(*) are obtained by interpolation. */ - -/* IDID = 4 -- the initial condition calculation, with */ -/* INFO(11) > 0, was successful, and INFO(14) = 1. */ -/* No integration steps were taken, and the solution */ -/* is not considered to have been started. */ - -/* *** TASK INTERRUPTED *** */ -/* Reported by negative values of IDID */ - -/* IDID = -1 -- a large amount of work has been expended */ -/* (about 500 steps). */ - -/* IDID = -2 -- the error tolerances are too stringent. */ - -/* IDID = -3 -- the local error test cannot be satisfied */ -/* because you specified a zero component in ATOL */ -/* and the corresponding computed solution component */ -/* is zero. Thus, a pure relative error test is */ -/* impossible for this component. */ - -/* IDID = -5 -- there were repeated failures in the evaluation */ -/* or processing of the preconditioner (in JAC). */ - -/* IDID = -6 -- DDASPK had repeated error test failures on the */ -/* last attempted step. */ - -/* IDID = -7 -- the nonlinear system solver in the time integration */ -/* could not converge. */ - -/* IDID = -8 -- the matrix of partial derivatives appears */ -/* to be singular (direct method). */ - -/* IDID = -9 -- the nonlinear system solver in the time integration */ -/* failed to achieve convergence, and there were repeated */ -/* error test failures in this step. */ - -/* IDID =-10 -- the nonlinear system solver in the time integration */ -/* failed to achieve convergence because IRES was equal */ -/* to -1. */ - -/* IDID =-11 -- IRES = -2 was encountered and control is */ -/* being returned to the calling program. */ - -/* IDID =-12 -- DDASPK failed to compute the initial Y, YPRIME. */ - -/* IDID =-13 -- unrecoverable error encountered inside user's */ -/* PSOL routine, and control is being returned to */ -/* the calling program. */ - -/* IDID =-14 -- the Krylov linear system solver could not */ -/* achieve convergence. */ - -/* IDID =-15,..,-32 -- Not applicable for this code. */ - -/* *** TASK TERMINATED *** */ -/* reported by the value of IDID=-33 */ - -/* IDID = -33 -- the code has encountered trouble from which */ -/* it cannot recover. A message is printed */ -/* explaining the trouble and control is returned */ -/* to the calling program. For example, this occurs */ -/* when invalid input is detected. */ - -/* RTOL, ATOL -- these quantities remain unchanged except when */ -/* IDID = -2. In this case, the error tolerances have been */ -/* increased by the code to values which are estimated to */ -/* be appropriate for continuing the integration. However, */ -/* the reported solution at T was obtained using the input */ -/* values of RTOL and ATOL. */ - -/* RWORK, IWORK -- contain information which is usually of no interest */ -/* to the user but necessary for subsequent calls. */ -/* However, you may be interested in the performance data */ -/* listed below. These quantities are accessed in RWORK */ -/* and IWORK but have internal mnemonic names, as follows.. */ - -/* RWORK(3)--contains H, the step size h to be attempted */ -/* on the next step. */ - -/* RWORK(4)--contains TN, the current value of the */ -/* independent variable, i.e. the farthest point */ -/* integration has reached. This will differ */ -/* from T if interpolation has been performed */ -/* (IDID = 3). */ - -/* RWORK(7)--contains HOLD, the stepsize used on the last */ -/* successful step. If INFO(11) = INFO(14) = 1, */ -/* this contains the value of H used in the */ -/* initial condition calculation. */ - -/* IWORK(7)--contains K, the order of the method to be */ -/* attempted on the next step. */ - -/* IWORK(8)--contains KOLD, the order of the method used */ -/* on the last step. */ - -/* IWORK(11)--contains NST, the number of steps (in T) */ -/* taken so far. */ - -/* IWORK(12)--contains NRE, the number of calls to RES */ -/* so far. */ - -/* IWORK(13)--contains NJE, the number of calls to JAC so */ -/* far (Jacobian or preconditioner evaluations). */ - -/* IWORK(14)--contains NETF, the total number of error test */ -/* failures so far. */ - -/* IWORK(15)--contains NCFN, the total number of nonlinear */ -/* convergence failures so far (includes counts */ -/* of singular iteration matrix or singular */ -/* preconditioners). */ - -/* IWORK(16)--contains NCFL, the number of convergence */ -/* failures of the linear iteration so far. */ - -/* IWORK(17)--contains LENIW, the length of IWORK actually */ -/* required. This is defined on normal returns */ -/* and on an illegal input return for */ -/* insufficient storage. */ - -/* IWORK(18)--contains LENRW, the length of RWORK actually */ -/* required. This is defined on normal returns */ -/* and on an illegal input return for */ -/* insufficient storage. */ - -/* IWORK(19)--contains NNI, the total number of nonlinear */ -/* iterations so far (each of which calls a */ -/* linear solver). */ - -/* IWORK(20)--contains NLI, the total number of linear */ -/* (Krylov) iterations so far. */ - -/* IWORK(21)--contains NPS, the number of PSOL calls so */ -/* far, for preconditioning solve operations or */ -/* for solutions with the user-supplied method. */ - -/* Note: The various counters in IWORK do not include */ -/* counts during a call made with INFO(11) > 0 and */ -/* INFO(14) = 1. */ - - -/* ------INPUT - WHAT TO DO TO CONTINUE THE INTEGRATION ----------------- */ -/* (CALLS AFTER THE FIRST) */ - -/* This code is organized so that subsequent calls to continue the */ -/* integration involve little (if any) additional effort on your */ -/* part. You must monitor the IDID parameter in order to determine */ -/* what to do next. */ - -/* Recalling that the principal task of the code is to integrate */ -/* from T to TOUT (the interval mode), usually all you will need */ -/* to do is specify a new TOUT upon reaching the current TOUT. */ - -/* Do not alter any quantity not specifically permitted below. In */ -/* particular do not alter NEQ, T, Y(*), YPRIME(*), RWORK(*), */ -/* IWORK(*), or the differential equation in subroutine RES. Any */ -/* such alteration constitutes a new problem and must be treated */ -/* as such, i.e. you must start afresh. */ - -/* You cannot change from array to scalar error control or vice */ -/* versa (INFO(2)), but you can change the size of the entries of */ -/* RTOL or ATOL. Increasing a tolerance makes the equation easier */ -/* to integrate. Decreasing a tolerance will make the equation */ -/* harder to integrate and should generally be avoided. */ - -/* You can switch from the intermediate-output mode to the */ -/* interval mode (INFO(3)) or vice versa at any time. */ - -/* If it has been necessary to prevent the integration from going */ -/* past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the */ -/* code will not integrate to any TOUT beyond the currently */ -/* specified TSTOP. Once TSTOP has been reached, you must change */ -/* the value of TSTOP or set INFO(4) = 0. You may change INFO(4) */ -/* or TSTOP at any time but you must supply the value of TSTOP in */ -/* RWORK(1) whenever you set INFO(4) = 1. */ - -/* Do not change INFO(5), INFO(6), INFO(12-17) or their associated */ -/* IWORK/RWORK locations unless you are going to restart the code. */ - -/* *** FOLLOWING A COMPLETED TASK *** */ - -/* If.. */ -/* IDID = 1, call the code again to continue the integration */ -/* another step in the direction of TOUT. */ - -/* IDID = 2 or 3, define a new TOUT and call the code again. */ -/* TOUT must be different from T. You cannot change */ -/* the direction of integration without restarting. */ - -/* IDID = 4, reset INFO(11) = 0 and call the code again to begin */ -/* the integration. (If you leave INFO(11) > 0 and */ -/* INFO(14) = 1, you may generate an infinite loop.) */ -/* In this situation, the next call to DASPK is */ -/* considered to be the first call for the problem, */ -/* in that all initializations are done. */ - -/* *** FOLLOWING AN INTERRUPTED TASK *** */ - -/* To show the code that you realize the task was interrupted and */ -/* that you want to continue, you must take appropriate action and */ -/* set INFO(1) = 1. */ - -/* If.. */ -/* IDID = -1, the code has taken about 500 steps. If you want to */ -/* continue, set INFO(1) = 1 and call the code again. */ -/* An additional 500 steps will be allowed. */ - - -/* IDID = -2, the error tolerances RTOL, ATOL have been increased */ -/* to values the code estimates appropriate for */ -/* continuing. You may want to change them yourself. */ -/* If you are sure you want to continue with relaxed */ -/* error tolerances, set INFO(1) = 1 and call the code */ -/* again. */ - -/* IDID = -3, a solution component is zero and you set the */ -/* corresponding component of ATOL to zero. If you */ -/* are sure you want to continue, you must first alter */ -/* the error criterion to use positive values of ATOL */ -/* for those components corresponding to zero solution */ -/* components, then set INFO(1) = 1 and call the code */ -/* again. */ - -/* IDID = -4 --- cannot occur with this code. */ - -/* IDID = -5, your JAC routine failed with the Krylov method. Check */ -/* for errors in JAC and restart the integration. */ - -/* IDID = -6, repeated error test failures occurred on the last */ -/* attempted step in DDASPK. A singularity in the */ -/* solution may be present. If you are absolutely */ -/* certain you want to continue, you should restart */ -/* the integration. (Provide initial values of Y and */ -/* YPRIME which are consistent.) */ - -/* IDID = -7, repeated convergence test failures occurred on the last */ -/* attempted step in DDASPK. An inaccurate or ill- */ -/* conditioned Jacobian or preconditioner may be the */ -/* problem. If you are absolutely certain you want */ -/* to continue, you should restart the integration. */ - - -/* IDID = -8, the matrix of partial derivatives is singular, with */ -/* the use of direct methods. Some of your equations */ -/* may be redundant. DDASPK cannot solve the problem */ -/* as stated. It is possible that the redundant */ -/* equations could be removed, and then DDASPK could */ -/* solve the problem. It is also possible that a */ -/* solution to your problem either does not exist */ -/* or is not unique. */ - -/* IDID = -9, DDASPK had multiple convergence test failures, preceded */ -/* by multiple error test failures, on the last */ -/* attempted step. It is possible that your problem is */ -/* ill-posed and cannot be solved using this code. Or, */ -/* there may be a discontinuity or a singularity in the */ -/* solution. If you are absolutely certain you want to */ -/* continue, you should restart the integration. */ - -/* IDID = -10, DDASPK had multiple convergence test failures */ -/* because IRES was equal to -1. If you are */ -/* absolutely certain you want to continue, you */ -/* should restart the integration. */ - -/* IDID = -11, there was an unrecoverable error (IRES = -2) from RES */ -/* inside the nonlinear system solver. Determine the */ -/* cause before trying again. */ - -/* IDID = -12, DDASPK failed to compute the initial Y and YPRIME */ -/* vectors. This could happen because the initial */ -/* approximation to Y or YPRIME was not very good, or */ -/* because no consistent values of these vectors exist. */ -/* The problem could also be caused by an inaccurate or */ -/* singular iteration matrix, or a poor preconditioner. */ - -/* IDID = -13, there was an unrecoverable error encountered inside */ -/* your PSOL routine. Determine the cause before */ -/* trying again. */ - -/* IDID = -14, the Krylov linear system solver failed to achieve */ -/* convergence. This may be due to ill-conditioning */ -/* in the iteration matrix, or a singularity in the */ -/* preconditioner (if one is being used). */ -/* Another possibility is that there is a better */ -/* choice of Krylov parameters (see INFO(13)). */ -/* Possibly the failure is caused by redundant equations */ -/* in the system, or by inconsistent equations. */ -/* In that case, reformulate the system to make it */ -/* consistent and non-redundant. */ - -/* IDID = -15,..,-32 --- Cannot occur with this code. */ - -/* *** FOLLOWING A TERMINATED TASK *** */ - -/* If IDID = -33, you cannot continue the solution of this problem. */ -/* An attempt to do so will result in your run being */ -/* terminated. */ - -/* --------------------------------------------------------------------- */ - -/* ***REFERENCES */ -/* 1. L. R. Petzold, A Description of DASSL: A Differential/Algebraic */ -/* System Solver, in Scientific Computing, R. S. Stepleman et al. */ -/* (Eds.), North-Holland, Amsterdam, 1983, pp. 65-68. */ -/* 2. K. E. Brenan, S. L. Campbell, and L. R. Petzold, Numerical */ -/* Solution of Initial-Value Problems in Differential-Algebraic */ -/* Equations, Elsevier, New York, 1989. */ -/* 3. P. N. Brown and A. C. Hindmarsh, Reduced Storage Matrix Methods */ -/* in Stiff ODE Systems, J. Applied Mathematics and Computation, */ -/* 31 (1989), pp. 40-91. */ -/* 4. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Using Krylov */ -/* Methods in the Solution of Large-Scale Differential-Algebraic */ -/* Systems, SIAM J. Sci. Comp., 15 (1994), pp. 1467-1488. */ -/* 5. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Consistent */ -/* Initial Condition Calculation for Differential-Algebraic */ -/* Systems, SIAM J. Sci. Comp. 19 (1998), pp. 1495-1512. */ - -/* ***ROUTINES CALLED */ - -/* The following are all the subordinate routines used by DDASPK. */ - -/* DDASIC computes consistent initial conditions. */ -/* DYYPNW updates Y and YPRIME in linesearch for initial condition */ -/* calculation. */ -/* DDSTP carries out one step of the integration. */ -/* DCNSTR/DCNST0 check the current solution for constraint violations. */ -/* DDAWTS sets error weight quantities. */ -/* DINVWT tests and inverts the error weights. */ -/* DDATRP performs interpolation to get an output solution. */ -/* DDWNRM computes the weighted root-mean-square norm of a vector. */ -/* D1MACH provides the unit roundoff of the computer. */ -/* XERRWD/XSETF/XSETUN/IXSAV is a package to handle error messages. */ -/* DDASID nonlinear equation driver to initialize Y and YPRIME using */ -/* direct linear system solver methods. Interfaces to Newton */ -/* solver (direct case). */ -/* DNSID solves the nonlinear system for unknown initial values by */ -/* modified Newton iteration and direct linear system methods. */ -/* DLINSD carries out linesearch algorithm for initial condition */ -/* calculation (direct case). */ -/* DFNRMD calculates weighted norm of preconditioned residual in */ -/* initial condition calculation (direct case). */ -/* DNEDD nonlinear equation driver for direct linear system solver */ -/* methods. Interfaces to Newton solver (direct case). */ -/* DMATD assembles the iteration matrix (direct case). */ -/* DNSD solves the associated nonlinear system by modified */ -/* Newton iteration and direct linear system methods. */ -/* DSLVD interfaces to linear system solver (direct case). */ -/* DDASIK nonlinear equation driver to initialize Y and YPRIME using */ -/* Krylov iterative linear system methods. Interfaces to */ -/* Newton solver (Krylov case). */ -/* DNSIK solves the nonlinear system for unknown initial values by */ -/* Newton iteration and Krylov iterative linear system methods. */ -/* DLINSK carries out linesearch algorithm for initial condition */ -/* calculation (Krylov case). */ -/* DFNRMK calculates weighted norm of preconditioned residual in */ -/* initial condition calculation (Krylov case). */ -/* DNEDK nonlinear equation driver for iterative linear system solver */ -/* methods. Interfaces to Newton solver (Krylov case). */ -/* DNSK solves the associated nonlinear system by Inexact Newton */ -/* iteration and (linear) Krylov iteration. */ -/* DSLVK interfaces to linear system solver (Krylov case). */ -/* DSPIGM solves a linear system by SPIGMR algorithm. */ -/* DATV computes matrix-vector product in Krylov algorithm. */ -/* DORTH performs orthogonalization of Krylov basis vectors. */ -/* DHEQR performs QR factorization of Hessenberg matrix. */ -/* DHELS finds least-squares solution of Hessenberg linear system. */ -/* DGEFA, DGESL, DGBFA, DGBSL are LINPACK routines for solving */ -/* linear systems (dense or band direct methods). */ -/* DAXPY, DCOPY, DDOT, DNRM2, DSCAL are Basic Linear Algebra (BLAS) */ -/* routines. */ - -/* The routines called directly by DDASPK are: */ -/* DCNST0, DDAWTS, DINVWT, D1MACH, DDWNRM, DDASIC, DDATRP, DDSTP, */ -/* XERRWD */ - -/* ***END PROLOGUE DDASPK */ - - - -/* Set pointers into IWORK. */ - - -/* Set pointers into RWORK. */ - - - - -/* ***FIRST EXECUTABLE STATEMENT DDASPK */ - - - /* Parameter adjustments */ - --y; - --yprime; - --info; - --rtol; - --atol; - --rwork; - --iwork; - --rpar; - --ipar; - - /* Function Body */ - if (info[1] != 0) { - goto L100; - } - -/* ----------------------------------------------------------------------- */ -/* This block is executed for the initial call only. */ -/* It contains checking of inputs and initializations. */ -/* ----------------------------------------------------------------------- */ - -/* First check INFO array to make sure all elements of INFO */ -/* Are within the proper range. (INFO(1) is checked later, because */ -/* it must be tested on every call.) ITEMP holds the location */ -/* within INFO which may be out of range. */ - - for (i__ = 2; i__ <= 9; ++i__) { - itemp = i__; - if (info[i__] != 0 && info[i__] != 1) { - goto L701; - } -/* L10: */ - } - itemp = 10; - if (info[10] < 0 || info[10] > 3) { - goto L701; - } - itemp = 11; - if (info[11] < 0 || info[11] > 2) { - goto L701; - } - for (i__ = 12; i__ <= 17; ++i__) { - itemp = i__; - if (info[i__] != 0 && info[i__] != 1) { - goto L701; - } -/* L15: */ - } - itemp = 18; - if (info[18] < 0 || info[18] > 2) { - goto L701; - } - -/* Check NEQ to see if it is positive. */ - - if (*neq <= 0) { - goto L702; - } - -/* Check and compute maximum order. */ - - mxord = 5; - if (info[9] != 0) { - mxord = iwork[3]; - if (mxord < 1 || mxord > 5) { - goto L703; - } - } - iwork[3] = mxord; - -/* Set and/or check inputs for constraint checking (INFO(10) .NE. 0). */ -/* Set values for ICNFLG, NONNEG, and pointer LID. */ - - icnflg = 0; - nonneg = 0; - lid = 41; - if (info[10] == 0) { - goto L20; - } - if (info[10] == 1) { - icnflg = 1; - nonneg = 0; - lid = *neq + 41; - } else if (info[10] == 2) { - icnflg = 0; - nonneg = 1; - } else { - icnflg = 1; - nonneg = 1; - lid = *neq + 41; - } - -L20: - -/* Set and/or check inputs for Krylov solver (INFO(12) .NE. 0). */ -/* If indicated, set default values for MAXL, KMP, NRMAX, and EPLI. */ -/* Otherwise, verify inputs required for iterative solver. */ - - if (info[12] == 0) { - goto L25; - } - - iwork[23] = info[12]; - if (info[13] == 0) { - iwork[24] = min(5,*neq); - iwork[25] = iwork[24]; - iwork[26] = 5; - rwork[10] = .05; - } else { - if (iwork[24] < 1 || iwork[24] > *neq) { - goto L720; - } - if (iwork[25] < 1 || iwork[25] > iwork[24]) { - goto L721; - } - if (iwork[26] < 0) { - goto L722; - } - if (rwork[10] <= 0. || rwork[10] >= 1.) { - goto L723; - } - } - -L25: - -/* Set and/or check controls for the initial condition calculation */ -/* (INFO(11) .GT. 0). If indicated, set default values. */ -/* Otherwise, verify inputs required for iterative solver. */ - - if (info[11] == 0) { - goto L30; - } - if (info[17] == 0) { - iwork[32] = 5; - if (info[12] > 0) { - iwork[32] = 15; - } - iwork[33] = 6; - if (info[12] > 0) { - iwork[33] = 2; - } - iwork[34] = 5; - iwork[35] = 0; - rwork[15] = .01; - } else { - if (iwork[32] <= 0) { - goto L725; - } - if (iwork[33] <= 0) { - goto L725; - } - if (iwork[34] <= 0) { - goto L725; - } - lsoff = iwork[35]; - if (lsoff < 0 || lsoff > 1) { - goto L725; - } - if (rwork[15] <= 0.) { - goto L725; - } - } - -L30: - -/* Below is the computation and checking of the work array lengths */ -/* LENIW and LENRW, using direct methods (INFO(12) = 0) or */ -/* the Krylov methods (INFO(12) = 1). */ - - lenic = 0; - if (info[10] == 1 || info[10] == 3) { - lenic = *neq; - } - lenid = 0; - if (info[11] == 1 || info[16] == 1) { - lenid = *neq; - } - if (info[12] == 0) { - -/* Compute MTYPE, etc. Check ML and MU. */ - -/* Computing MAX */ - i__1 = mxord + 1; - ncphi = max(i__1,4); - if (info[6] == 0) { -/* Computing 2nd power */ - i__1 = *neq; - lenpd = i__1 * i__1; - lenrw = (ncphi + 3) * *neq + 50 + lenpd; - if (info[5] == 0) { - iwork[4] = 2; - } else { - iwork[4] = 1; - } - } else { - if (iwork[1] < 0 || iwork[1] >= *neq) { - goto L717; - } - if (iwork[2] < 0 || iwork[2] >= *neq) { - goto L718; - } - lenpd = ((iwork[1] << 1) + iwork[2] + 1) * *neq; - if (info[5] == 0) { - iwork[4] = 5; - mband = iwork[1] + iwork[2] + 1; - msave = *neq / mband + 1; - lenrw = (ncphi + 3) * *neq + 50 + lenpd + (msave << 1); - } else { - iwork[4] = 4; - lenrw = (ncphi + 3) * *neq + 50 + lenpd; - } - } - -/* Compute LENIW, LENWP, LENIWP. */ - - leniw = lenic + 40 + lenid + *neq; - lenwp = 0; - leniwp = 0; - - } else if (info[12] == 1) { - ncphi = mxord + 1; - maxl = iwork[24]; - lenwp = iwork[27]; - leniwp = iwork[28]; -/* Computing MIN */ - i__1 = 1, i__2 = maxl - iwork[25]; - lenpd = (maxl + 3 + min(i__1,i__2)) * *neq + (maxl + 3) * maxl + 1 + - lenwp; - lenrw = (mxord + 5) * *neq + 50 + lenpd; - leniw = lenic + 40 + lenid + leniwp; - - } - if (info[16] != 0) { - lenrw += *neq; - } - -/* Check lengths of RWORK and IWORK. */ - - iwork[17] = leniw; - iwork[18] = lenrw; - iwork[22] = lenpd; - iwork[29] = lenpd - lenwp + 1; - if (*lrw < lenrw) { - goto L704; - } - if (*liw < leniw) { - goto L705; - } - -/* Check ICNSTR for legality. */ - - if (lenic > 0) { - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - ici = iwork[i__ + 40]; - if (ici < -2 || ici > 2) { - goto L726; - } -/* L40: */ - } - } - -/* Check Y for consistency with constraints. */ - - if (lenic > 0) { - dcnst0_(neq, &y[1], &iwork[41], &iret); - if (iret != 0) { - goto L727; - } - } - -/* Check ID for legality and set INDEX = 0 or 1. */ - - index = 1; - if (lenid > 0) { - index = 0; - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - idi = iwork[lid - 1 + i__]; - if (idi != 1 && idi != -1) { - goto L724; - } - if (idi == -1) { - index = 1; - } -/* L50: */ - } - } - -/* Check to see that TOUT is different from T. */ - - if (*tout == *t) { - goto L719; - } - -/* Check HMAX. */ - - if (info[7] != 0) { - hmax = rwork[2]; - if (hmax <= 0.) { - goto L710; - } - } - -/* Initialize counters and other flags. */ - - iwork[11] = 0; - iwork[12] = 0; - iwork[13] = 0; - iwork[14] = 0; - iwork[15] = 0; - iwork[19] = 0; - iwork[20] = 0; - iwork[21] = 0; - iwork[16] = 0; - iwork[31] = info[18]; - *idid = 1; - goto L200; - -/* ----------------------------------------------------------------------- */ -/* This block is for continuation calls only. */ -/* Here we check INFO(1), and if the last step was interrupted, */ -/* we check whether appropriate action was taken. */ -/* ----------------------------------------------------------------------- */ - -L100: - if (info[1] == 1) { - goto L110; - } - itemp = 1; - if (info[1] != -1) { - goto L701; - } - -/* If we are here, the last step was interrupted by an error */ -/* condition from DDSTP, and appropriate action was not taken. */ -/* This is a fatal error. */ - - s_copy(msg, "DASPK-- THE LAST STEP TERMINATED WITH A NEGATIVE", (ftnlen) - 80, (ftnlen)49); - xerrwd_(msg, &c__49, &c__201, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - s_copy(msg, "DASPK-- VALUE (=I1) OF IDID AND NO APPROPRIATE", (ftnlen)80, - (ftnlen)47); - xerrwd_(msg, &c__47, &c__202, &c__0, &c__1, idid, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - s_copy(msg, "DASPK-- ACTION WAS TAKEN. RUN TERMINATED", (ftnlen)80, ( - ftnlen)41); - xerrwd_(msg, &c__41, &c__203, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - return 0; -L110: - -/* ----------------------------------------------------------------------- */ -/* This block is executed on all calls. */ - -/* Counters are saved for later checks of performance. */ -/* Then the error tolerance parameters are checked, and the */ -/* work array pointers are set. */ -/* ----------------------------------------------------------------------- */ - -L200: - -/* Save counters for use later. */ - - iwork[10] = iwork[11]; - nli0 = iwork[20]; - nni0 = iwork[19]; - ncfn0 = iwork[15]; - ncfl0 = iwork[16]; - nwarn = 0; - -/* Check RTOL and ATOL. */ - - nzflg = 0; - rtoli = rtol[1]; - atoli = atol[1]; - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - if (info[2] == 1) { - rtoli = rtol[i__]; - } - if (info[2] == 1) { - atoli = atol[i__]; - } - if (rtoli > 0. || atoli > 0.) { - nzflg = 1; - } - if (rtoli < 0.) { - goto L706; - } - if (atoli < 0.) { - goto L707; - } -/* L210: */ - } - if (nzflg == 0) { - goto L708; - } - -/* Set pointers to RWORK and IWORK segments. */ -/* For direct methods, SAVR is not used. */ - - iwork[30] = lid + lenid; - lsavr = 51; - if (info[12] != 0) { - lsavr = *neq + 51; - } - le = lsavr + *neq; - lwt = le + *neq; - lvt = lwt; - if (info[16] != 0) { - lvt = lwt + *neq; - } - lphi = lvt + *neq; - lwm = lphi + ncphi * *neq; - if (info[1] == 1) { - goto L400; - } - -/* ----------------------------------------------------------------------- */ -/* This block is executed on the initial call only. */ -/* Set the initial step size, the error weight vector, and PHI. */ -/* Compute unknown initial components of Y and YPRIME, if requested. */ -/* ----------------------------------------------------------------------- */ - -/* L300: */ - tn = *t; - *idid = 1; - -/* Set error weight array WT and altered weight array VT. */ - - ddawts_(neq, &info[2], &rtol[1], &atol[1], &y[1], &rwork[lwt], &rpar[1], & - ipar[1]); - dinvwt_(neq, &rwork[lwt], &ier); - if (ier != 0) { - goto L713; - } - if (info[16] != 0) { - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L305: */ -/* Computing MAX */ - i__2 = iwork[lid + i__ - 1]; - rwork[lvt + i__ - 1] = max(i__2,0) * rwork[lwt + i__ - 1]; - } - } - -/* Compute unit roundoff and HMIN. */ - - uround = d1mach_(&lc__4); - rwork[9] = uround; -/* Computing MAX */ - d__1 = abs(*t), d__2 = abs(*tout); - hmin = uround * 4. * max(d__1,d__2); - -/* Set/check STPTOL control for initial condition calculation. */ - - if (info[11] != 0) { - if (info[17] == 0) { - rwork[14] = pow_dd(&uround, &c_b67); - } else { - if (rwork[14] <= 0.) { - goto L725; - } - } - } - -/* Compute EPCON and square root of NEQ and its reciprocal, used */ -/* inside iterative solver. */ - - rwork[13] = .33; - floatn = (doublereal) (*neq); - rwork[11] = sqrt(floatn); - rwork[12] = 1. / rwork[11]; - -/* Check initial interval to see that it is long enough. */ - - tdist = (d__1 = *tout - *t, abs(d__1)); - if (tdist < hmin) { - goto L714; - } - -/* Check H0, if this was input. */ - - if (info[8] == 0) { - goto L310; - } - h0 = rwork[3]; - if ((*tout - *t) * h0 < 0.) { - goto L711; - } - if (h0 == 0.) { - goto L712; - } - goto L320; -L310: - -/* Compute initial stepsize, to be used by either */ -/* DDSTP or DDASIC, depending on INFO(11). */ - - h0 = tdist * .001; - ypnorm = ddwnrm_(neq, &yprime[1], &rwork[lvt], &rpar[1], &ipar[1]); - if (ypnorm > .5 / h0) { - h0 = .5 / ypnorm; - } - d__1 = *tout - *t; - h0 = d_sign(&h0, &d__1); - -/* Adjust H0 if necessary to meet HMAX bound. */ - -L320: - if (info[7] == 0) { - goto L330; - } - rh = abs(h0) / rwork[2]; - if (rh > 1.) { - h0 /= rh; - } - -/* Check against TSTOP, if applicable. */ - -L330: - if (info[4] == 0) { - goto L340; - } - tstop = rwork[1]; - s_wsle(&io___49); - do_lio(&c__9, &c__1, "tstop = ", (ftnlen)8); - do_lio(&c__5, &c__1, (char *)&tstop, (ftnlen)sizeof(doublereal)); - e_wsle(); - if ((tstop - *t) * h0 < 0.) { - goto L715; - } - if ((*t + h0 - tstop) * h0 > 0.) { - h0 = tstop - *t; - } - if ((tstop - *tout) * h0 < 0.) { - goto L709; - } - -L340: - if (info[11] == 0) { - goto L370; - } - -/* Compute unknown components of initial Y and YPRIME, depending */ -/* on INFO(11) and INFO(12). INFO(12) represents the nonlinear */ -/* solver type (direct/Krylov). Pass the name of the specific */ -/* nonlinear solver, depending on INFO(12). The location of the work */ -/* arrays SAVR, YIC, YPIC, PWK also differ in the two cases. */ -/* For use in stopping tests, pass TSCALE = TDIST if INDEX = 0. */ - - nwt = 1; - epconi = rwork[15] * rwork[13]; - tscale = 0.; - if (index == 0) { - tscale = tdist; - } -L350: - if (info[12] == 0) { - lyic = lphi + (*neq << 1); - lypic = lyic + *neq; - lpwk = lypic; - ddasic_(&tn, &y[1], &yprime[1], neq, &info[11], &iwork[lid], (U_fp) - res, (U_fp)jac, (U_fp)psol, &h0, &tscale, &rwork[lwt], &nwt, - idid, &rpar[1], &ipar[1], &rwork[lphi], &rwork[lsavr], &rwork[ - 51], &rwork[le], &rwork[lyic], &rwork[lypic], &rwork[lpwk], & - rwork[lwm], &iwork[1], &rwork[9], &rwork[10], &rwork[11], & - rwork[12], &epconi, &rwork[14], &info[15], &icnflg, &iwork[41] - , (U_fp)ddasid_); - } else if (info[12] == 1) { - lyic = lwm; - lypic = lyic + *neq; - lpwk = lypic + *neq; - ddasic_(&tn, &y[1], &yprime[1], neq, &info[11], &iwork[lid], (U_fp) - res, (U_fp)jac, (U_fp)psol, &h0, &tscale, &rwork[lwt], &nwt, - idid, &rpar[1], &ipar[1], &rwork[lphi], &rwork[lsavr], &rwork[ - 51], &rwork[le], &rwork[lyic], &rwork[lypic], &rwork[lpwk], & - rwork[lwm], &iwork[1], &rwork[9], &rwork[10], &rwork[11], & - rwork[12], &epconi, &rwork[14], &info[15], &icnflg, &iwork[41] - , (U_fp)ddasik_); - } - - if (*idid < 0) { - goto L600; - } - -/* DDASIC was successful. If this was the first call to DDASIC, */ -/* update the WT array (with the current Y) and call it again. */ - - if (nwt == 2) { - goto L355; - } - nwt = 2; - ddawts_(neq, &info[2], &rtol[1], &atol[1], &y[1], &rwork[lwt], &rpar[1], & - ipar[1]); - dinvwt_(neq, &rwork[lwt], &ier); - if (ier != 0) { - goto L713; - } - goto L350; - -/* If INFO(14) = 1, return now with IDID = 4. */ - -L355: - if (info[14] == 1) { - *idid = 4; - h__ = h0; - if (info[11] == 1) { - rwork[7] = h0; - } - goto L590; - } - -/* Update the WT and VT arrays one more time, with the new Y. */ - - ddawts_(neq, &info[2], &rtol[1], &atol[1], &y[1], &rwork[lwt], &rpar[1], & - ipar[1]); - dinvwt_(neq, &rwork[lwt], &ier); - if (ier != 0) { - goto L713; - } - if (info[16] != 0) { - i__2 = *neq; - for (i__ = 1; i__ <= i__2; ++i__) { -/* L357: */ -/* Computing MAX */ - i__1 = iwork[lid + i__ - 1]; - rwork[lvt + i__ - 1] = max(i__1,0) * rwork[lwt + i__ - 1]; - } - } - -/* Reset the initial stepsize to be used by DDSTP. */ -/* Use H0, if this was input. Otherwise, recompute H0, */ -/* and adjust it if necessary to meet HMAX bound. */ - - if (info[8] != 0) { - h0 = rwork[3]; - goto L360; - } - - h0 = tdist * .001; - ypnorm = ddwnrm_(neq, &yprime[1], &rwork[lvt], &rpar[1], &ipar[1]); - if (ypnorm > .5 / h0) { - h0 = .5 / ypnorm; - } - d__1 = *tout - *t; - h0 = d_sign(&h0, &d__1); - -L360: - if (info[7] != 0) { - rh = abs(h0) / rwork[2]; - if (rh > 1.) { - h0 /= rh; - } - } - -/* Check against TSTOP, if applicable. */ - - if (info[4] != 0) { - tstop = rwork[1]; - s_wsle(&io___57); - do_lio(&c__9, &c__1, "tstop = ", (ftnlen)8); - do_lio(&c__5, &c__1, (char *)&tstop, (ftnlen)sizeof(doublereal)); - e_wsle(); - if ((*t + h0 - tstop) * h0 > 0.) { - h0 = tstop - *t; - } - } - -/* Load H and RWORK(LH) with H0. */ - -L370: - h__ = h0; - rwork[3] = h__; - -/* Load Y and H*YPRIME into PHI(*,1) and PHI(*,2). */ - - itemp = lphi + *neq; - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - rwork[lphi + i__ - 1] = y[i__]; -/* L380: */ - rwork[itemp + i__ - 1] = h__ * yprime[i__]; - } - - goto L500; - -/* ----------------------------------------------------------------------- */ -/* This block is for continuation calls only. */ -/* Its purpose is to check stop conditions before taking a step. */ -/* Adjust H if necessary to meet HMAX bound. */ -/* ----------------------------------------------------------------------- */ - -L400: - uround = rwork[9]; - done = FALSE_; - tn = rwork[4]; - h__ = rwork[3]; - if (info[7] == 0) { - goto L410; - } - rh = abs(h__) / rwork[2]; - if (rh > 1.) { - h__ /= rh; - } -L410: - if (*t == *tout) { - goto L719; - } - if ((*t - *tout) * h__ > 0.) { - goto L711; - } - if (info[4] == 1) { - goto L430; - } - if (info[3] == 1) { - goto L420; - } - if ((tn - *tout) * h__ < 0.) { - goto L490; - } - ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & - rwork[39]); - *t = *tout; - *idid = 3; - done = TRUE_; - goto L490; -L420: - if ((tn - *t) * h__ <= 0.) { - goto L490; - } - if ((tn - *tout) * h__ >= 0.) { - goto L425; - } - ddatrp_(&tn, &tn, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &rwork[ - 39]); - *t = tn; - *idid = 1; - done = TRUE_; - goto L490; -L425: - ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & - rwork[39]); - *t = *tout; - *idid = 3; - done = TRUE_; - goto L490; -L430: - if (info[3] == 1) { - goto L440; - } - tstop = rwork[1]; - s_wsle(&io___59); - do_lio(&c__9, &c__1, "tstop = ", (ftnlen)8); - do_lio(&c__5, &c__1, (char *)&tstop, (ftnlen)sizeof(doublereal)); - e_wsle(); - if ((tn - tstop) * h__ > 0.) { - goto L715; - } - if ((tstop - *tout) * h__ < 0.) { - goto L709; - } - if ((tn - *tout) * h__ < 0.) { - goto L450; - } - ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & - rwork[39]); - *t = *tout; - *idid = 3; - done = TRUE_; - goto L490; -L440: - tstop = rwork[1]; - s_wsle(&io___60); - do_lio(&c__9, &c__1, "tstop = ", (ftnlen)8); - do_lio(&c__5, &c__1, (char *)&tstop, (ftnlen)sizeof(doublereal)); - e_wsle(); - if ((tn - tstop) * h__ > 0.) { - goto L715; - } - if ((tstop - *tout) * h__ < 0.) { - goto L709; - } - if ((tn - *t) * h__ <= 0.) { - goto L450; - } - if ((tn - *tout) * h__ >= 0.) { - goto L445; - } - ddatrp_(&tn, &tn, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], &rwork[ - 39]); - *t = tn; - *idid = 1; - done = TRUE_; - goto L490; -L445: - ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & - rwork[39]); - *t = *tout; - *idid = 3; - done = TRUE_; - goto L490; -L450: - -/* Check whether we are within roundoff of TSTOP. */ - - if ((d__1 = tn - tstop, abs(d__1)) > uround * 100. * (abs(tn) + abs(h__))) - { - goto L460; - } - ddatrp_(&tn, &tstop, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & - rwork[39]); - *idid = 2; - *t = tstop; - done = TRUE_; - goto L490; -L460: - tnext = tn + h__; - if ((tnext - tstop) * h__ <= 0.) { - goto L490; - } - h__ = tstop - tn; - rwork[3] = h__; - -L490: - if (done) { - goto L590; - } - -/* ----------------------------------------------------------------------- */ -/* The next block contains the call to the one-step integrator DDSTP. */ -/* This is a looping point for the integration steps. */ -/* Check for too many steps. */ -/* Check for poor Newton/Krylov performance. */ -/* Update WT. Check for too much accuracy requested. */ -/* Compute minimum stepsize. */ -/* ----------------------------------------------------------------------- */ - -L500: - -/* Check for too many steps. */ - - if (iwork[11] - iwork[10] < 500) { - goto L505; - } - *idid = -1; - goto L527; - -/* Check for poor Newton/Krylov performance. */ - -L505: - if (info[12] == 0) { - goto L510; - } - nstd = iwork[11] - iwork[10]; - nnid = iwork[19] - nni0; - if (nstd < 10 || nnid == 0) { - goto L510; - } - avlin = (real) (iwork[20] - nli0) / (real) nnid; - rcfn = (real) (iwork[15] - ncfn0) / (real) nstd; - rcfl = (real) (iwork[16] - ncfl0) / (real) nnid; - fmaxl = (doublereal) iwork[24]; - lavl = avlin > fmaxl; - lcfn = rcfn > .9; - lcfl = rcfl > .9; - lwarn = lavl || lcfn || lcfl; - if (! lwarn) { - goto L510; - } - ++nwarn; - if (nwarn > 10) { - goto L510; - } - if (lavl) { - s_copy(msg, "DASPK-- Warning. Poor iterative algorithm performance " - , (ftnlen)80, (ftnlen)56); - xerrwd_(msg, &c__56, &c__501, &c__0, &c__0, &c__0, &c__0, &c__0, & - c_b37, &c_b37, (ftnlen)80); - s_copy(msg, " at T = R1. Average no. of linear iterations = R2 " - , (ftnlen)80, (ftnlen)56); - xerrwd_(msg, &c__56, &c__501, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, - &avlin, (ftnlen)80); - } - if (lcfn) { - s_copy(msg, "DASPK-- Warning. Poor iterative algorithm performance " - , (ftnlen)80, (ftnlen)56); - xerrwd_(msg, &c__56, &c__502, &c__0, &c__0, &c__0, &c__0, &c__0, & - c_b37, &c_b37, (ftnlen)80); - s_copy(msg, " at T = R1. Nonlinear convergence failure rate = R2" - , (ftnlen)80, (ftnlen)56); - xerrwd_(msg, &c__56, &c__502, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, - &rcfn, (ftnlen)80); - } - if (lcfl) { - s_copy(msg, "DASPK-- Warning. Poor iterative algorithm performance " - , (ftnlen)80, (ftnlen)56); - xerrwd_(msg, &c__56, &c__503, &c__0, &c__0, &c__0, &c__0, &c__0, & - c_b37, &c_b37, (ftnlen)80); - s_copy(msg, " at T = R1. Linear convergence failure rate = R2 " - , (ftnlen)80, (ftnlen)56); - xerrwd_(msg, &c__56, &c__503, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, - &rcfl, (ftnlen)80); - } - -/* Update WT and VT, if this is not the first call. */ - -L510: - ddawts_(neq, &info[2], &rtol[1], &atol[1], &rwork[lphi], &rwork[lwt], & - rpar[1], &ipar[1]); - dinvwt_(neq, &rwork[lwt], &ier); - if (ier != 0) { - *idid = -3; - goto L527; - } - if (info[16] != 0) { - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L515: */ -/* Computing MAX */ - i__2 = iwork[lid + i__ - 1]; - rwork[lvt + i__ - 1] = max(i__2,0) * rwork[lwt + i__ - 1]; - } - } - -/* Test for too much accuracy requested. */ - - r__ = ddwnrm_(neq, &rwork[lphi], &rwork[lwt], &rpar[1], &ipar[1]) * 100. * - uround; - if (r__ <= 1.) { - goto L525; - } - -/* Multiply RTOL and ATOL by R and return. */ - - if (info[2] == 1) { - goto L523; - } - rtol[1] = r__ * rtol[1]; - atol[1] = r__ * atol[1]; - *idid = -2; - goto L527; -L523: - i__2 = *neq; - for (i__ = 1; i__ <= i__2; ++i__) { - rtol[i__] = r__ * rtol[i__]; -/* L524: */ - atol[i__] = r__ * atol[i__]; - } - *idid = -2; - goto L527; -L525: - -/* Compute minimum stepsize. */ - -/* Computing MAX */ - d__1 = abs(tn), d__2 = abs(*tout); - hmin = uround * 4. * max(d__1,d__2); - -/* Test H vs. HMAX */ - if (info[7] != 0) { - rh = abs(h__) / rwork[2]; - if (rh > 1.) { - h__ /= rh; - } - } - -/* Call the one-step integrator. */ -/* Note that INFO(12) represents the nonlinear solver type. */ -/* Pass the required nonlinear solver, depending upon INFO(12). */ - - if (info[12] == 0) { - ddstp_(&tn, &y[1], &yprime[1], neq, (U_fp)res, (U_fp)jac, (U_fp)psol, - &h__, &rwork[lwt], &rwork[lvt], &info[1], idid, &rpar[1], & - ipar[1], &rwork[lphi], &rwork[lsavr], &rwork[51], &rwork[le], - &rwork[lwm], &iwork[1], &rwork[21], &rwork[27], &rwork[33], & - rwork[39], &rwork[45], &rwork[5], &rwork[6], &rwork[7], & - rwork[8], &hmin, &rwork[9], &rwork[10], &rwork[11], &rwork[12] - , &rwork[13], &iwork[6], &iwork[5], &info[15], &iwork[7], & - iwork[8], &iwork[9], &nonneg, &info[12], (U_fp)dnedd_); - } else if (info[12] == 1) { - ddstp_(&tn, &y[1], &yprime[1], neq, (U_fp)res, (U_fp)jac, (U_fp)psol, - &h__, &rwork[lwt], &rwork[lvt], &info[1], idid, &rpar[1], & - ipar[1], &rwork[lphi], &rwork[lsavr], &rwork[51], &rwork[le], - &rwork[lwm], &iwork[1], &rwork[21], &rwork[27], &rwork[33], & - rwork[39], &rwork[45], &rwork[5], &rwork[6], &rwork[7], & - rwork[8], &hmin, &rwork[9], &rwork[10], &rwork[11], &rwork[12] - , &rwork[13], &iwork[6], &iwork[5], &info[15], &iwork[7], & - iwork[8], &iwork[9], &nonneg, &info[12], (U_fp)dnedk_); - } - -L527: - if (*idid < 0) { - goto L600; - } - -/* ----------------------------------------------------------------------- */ -/* This block handles the case of a successful return from DDSTP */ -/* (IDID=1). Test for stop conditions. */ -/* ----------------------------------------------------------------------- */ - - if (info[4] != 0) { - goto L540; - } - if (info[3] != 0) { - goto L530; - } - if ((tn - *tout) * h__ < 0.) { - goto L500; - } - ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & - rwork[39]); - *idid = 3; - *t = *tout; - goto L580; -L530: - if ((tn - *tout) * h__ >= 0.) { - goto L535; - } - *t = tn; - *idid = 1; - goto L580; -L535: - ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & - rwork[39]); - *idid = 3; - *t = *tout; - goto L580; -L540: - if (info[3] != 0) { - goto L550; - } - if ((tn - *tout) * h__ < 0.) { - goto L542; - } - ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & - rwork[39]); - *t = *tout; - *idid = 3; - goto L580; -L542: - if ((d__1 = tn - tstop, abs(d__1)) <= uround * 100. * (abs(tn) + abs(h__)) - ) { - goto L545; - } - tnext = tn + h__; - if ((tnext - tstop) * h__ <= 0.) { - goto L500; - } - h__ = tstop - tn; - goto L500; -L545: - ddatrp_(&tn, &tstop, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & - rwork[39]); - *idid = 2; - *t = tstop; - goto L580; -L550: - if ((tn - *tout) * h__ >= 0.) { - goto L555; - } - if ((d__1 = tn - tstop, abs(d__1)) <= uround * 100. * (abs(tn) + abs(h__)) - ) { - goto L552; - } - *t = tn; - *idid = 1; - goto L580; -L552: - ddatrp_(&tn, &tstop, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & - rwork[39]); - *idid = 2; - *t = tstop; - goto L580; -L555: - ddatrp_(&tn, tout, &y[1], &yprime[1], neq, &iwork[8], &rwork[lphi], & - rwork[39]); - *t = *tout; - *idid = 3; -L580: - -/* ----------------------------------------------------------------------- */ -/* All successful returns from DDASPK are made from this block. */ -/* ----------------------------------------------------------------------- */ - -L590: - rwork[4] = tn; - rwork[3] = h__; - return 0; - -/* ----------------------------------------------------------------------- */ -/* This block handles all unsuccessful returns other than for */ -/* illegal input. */ -/* ----------------------------------------------------------------------- */ - -L600: - itemp = -(*idid); - switch (itemp) { - case 1: goto L610; - case 2: goto L620; - case 3: goto L630; - case 4: goto L700; - case 5: goto L655; - case 6: goto L640; - case 7: goto L650; - case 8: goto L660; - case 9: goto L670; - case 10: goto L675; - case 11: goto L680; - case 12: goto L685; - case 13: goto L690; - case 14: goto L695; - } - -/* The maximum number of steps was taken before */ -/* reaching tout. */ - -L610: - s_copy(msg, "DASPK-- AT CURRENT T (=R1) 500 STEPS", (ftnlen)80, (ftnlen) - 38); - xerrwd_(msg, &c__38, &c__610, &c__0, &c__0, &c__0, &c__0, &c__1, &tn, & - c_b37, (ftnlen)80); - s_copy(msg, "DASPK-- TAKEN ON THIS CALL BEFORE REACHING TOUT", (ftnlen) - 80, (ftnlen)48); - xerrwd_(msg, &c__48, &c__611, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L700; - -/* Too much accuracy for machine precision. */ - -L620: - s_copy(msg, "DASPK-- AT T (=R1) TOO MUCH ACCURACY REQUESTED", (ftnlen)80, - (ftnlen)47); - xerrwd_(msg, &c__47, &c__620, &c__0, &c__0, &c__0, &c__0, &c__1, &tn, & - c_b37, (ftnlen)80); - s_copy(msg, "DASPK-- FOR PRECISION OF MACHINE. RTOL AND ATOL", (ftnlen) - 80, (ftnlen)48); - xerrwd_(msg, &c__48, &c__621, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - s_copy(msg, "DASPK-- WERE INCREASED TO APPROPRIATE VALUES", (ftnlen)80, ( - ftnlen)45); - xerrwd_(msg, &c__45, &c__622, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L700; - -/* WT(I) .LE. 0.0D0 for some I (not at start of problem). */ - -L630: - s_copy(msg, "DASPK-- AT T (=R1) SOME ELEMENT OF WT", (ftnlen)80, (ftnlen) - 38); - xerrwd_(msg, &c__38, &c__630, &c__0, &c__0, &c__0, &c__0, &c__1, &tn, & - c_b37, (ftnlen)80); - s_copy(msg, "DASPK-- HAS BECOME .LE. 0.0", (ftnlen)80, (ftnlen)28); - xerrwd_(msg, &c__28, &c__631, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L700; - -/* Error test failed repeatedly or with H=HMIN. */ - -L640: - s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, ( - ftnlen)44); - xerrwd_(msg, &c__44, &c__640, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & - h__, (ftnlen)80); - s_copy(msg, "DASPK-- ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN", ( - ftnlen)80, (ftnlen)57); - xerrwd_(msg, &c__57, &c__641, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L700; - -/* Nonlinear solver failed to converge repeatedly or with H=HMIN. */ - -L650: - s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, ( - ftnlen)44); - xerrwd_(msg, &c__44, &c__650, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & - h__, (ftnlen)80); - s_copy(msg, "DASPK-- NONLINEAR SOLVER FAILED TO CONVERGE", (ftnlen)80, ( - ftnlen)44); - xerrwd_(msg, &c__44, &c__651, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - s_copy(msg, "DASPK-- REPEATEDLY OR WITH ABS(H)=HMIN", (ftnlen)80, ( - ftnlen)39); - xerrwd_(msg, &c__40, &c__652, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L700; - -/* The preconditioner had repeated failures. */ - -L655: - s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, ( - ftnlen)44); - xerrwd_(msg, &c__44, &c__655, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & - h__, (ftnlen)80); - s_copy(msg, "DASPK-- PRECONDITIONER HAD REPEATED FAILURES.", (ftnlen)80, - (ftnlen)46); - xerrwd_(msg, &c__46, &c__656, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L700; - -/* The iteration matrix is singular. */ - -L660: - s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, ( - ftnlen)44); - xerrwd_(msg, &c__44, &c__660, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & - h__, (ftnlen)80); - s_copy(msg, "DASPK-- ITERATION MATRIX IS SINGULAR.", (ftnlen)80, (ftnlen) - 38); - xerrwd_(msg, &c__38, &c__661, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L700; - -/* Nonlinear system failure preceded by error test failures. */ - -L670: - s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, ( - ftnlen)44); - xerrwd_(msg, &c__44, &c__670, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & - h__, (ftnlen)80); - s_copy(msg, "DASPK-- NONLINEAR SOLVER COULD NOT CONVERGE.", (ftnlen)80, ( - ftnlen)45); - xerrwd_(msg, &c__45, &c__671, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - s_copy(msg, "DASPK-- ALSO, THE ERROR TEST FAILED REPEATEDLY.", (ftnlen) - 80, (ftnlen)48); - xerrwd_(msg, &c__49, &c__672, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L700; - -/* Nonlinear system failure because IRES = -1. */ - -L675: - s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, ( - ftnlen)44); - xerrwd_(msg, &c__44, &c__675, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & - h__, (ftnlen)80); - s_copy(msg, "DASPK-- NONLINEAR SYSTEM SOLVER COULD NOT CONVERGE", ( - ftnlen)80, (ftnlen)51); - xerrwd_(msg, &c__51, &c__676, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - s_copy(msg, "DASPK-- BECAUSE IRES WAS EQUAL TO MINUS ONE", (ftnlen)80, ( - ftnlen)44); - xerrwd_(msg, &c__44, &c__677, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L700; - -/* Failure because IRES = -2. */ - -L680: - s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2)", (ftnlen)80, ( - ftnlen)40); - xerrwd_(msg, &c__40, &c__680, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & - h__, (ftnlen)80); - s_copy(msg, "DASPK-- IRES WAS EQUAL TO MINUS TWO", (ftnlen)80, (ftnlen) - 36); - xerrwd_(msg, &c__36, &c__681, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L700; - -/* Failed to compute initial YPRIME. */ - -L685: - s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, ( - ftnlen)44); - xerrwd_(msg, &c__44, &c__685, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - s_copy(msg, "DASPK-- INITIAL (Y,YPRIME) COULD NOT BE COMPUTED", (ftnlen) - 80, (ftnlen)49); - xerrwd_(msg, &c__49, &c__686, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, &h0, - (ftnlen)80); - goto L700; - -/* Failure because IER was negative from PSOL. */ - -L690: - s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2)", (ftnlen)80, ( - ftnlen)40); - xerrwd_(msg, &c__40, &c__690, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & - h__, (ftnlen)80); - s_copy(msg, "DASPK-- IER WAS NEGATIVE FROM PSOL", (ftnlen)80, (ftnlen)35) - ; - xerrwd_(msg, &c__35, &c__691, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L700; - -/* Failure because the linear system solver could not converge. */ - -L695: - s_copy(msg, "DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE", (ftnlen)80, ( - ftnlen)44); - xerrwd_(msg, &c__44, &c__695, &c__0, &c__0, &c__0, &c__0, &c__2, &tn, & - h__, (ftnlen)80); - s_copy(msg, "DASPK-- LINEAR SYSTEM SOLVER COULD NOT CONVERGE.", (ftnlen) - 80, (ftnlen)49); - xerrwd_(msg, &c__50, &c__696, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L700; - - -L700: - info[1] = -1; - *t = tn; - rwork[4] = tn; - rwork[3] = h__; - return 0; - -/* ----------------------------------------------------------------------- */ -/* This block handles all error returns due to illegal input, */ -/* as detected before calling DDSTP. */ -/* First the error message routine is called. If this happens */ -/* twice in succession, execution is terminated. */ -/* ----------------------------------------------------------------------- */ - -L701: - s_copy(msg, "DASPK-- ELEMENT (=I1) OF INFO VECTOR IS NOT VALID", (ftnlen) - 80, (ftnlen)50); - xerrwd_(msg, &c__50, &c__1, &c__0, &c__1, &itemp, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L750; -L702: - s_copy(msg, "DASPK-- NEQ (=I1) .LE. 0", (ftnlen)80, (ftnlen)25); - xerrwd_(msg, &c__25, &c__2, &c__0, &c__1, neq, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L750; -L703: - s_copy(msg, "DASPK-- MAXORD (=I1) NOT IN RANGE", (ftnlen)80, (ftnlen)34); - xerrwd_(msg, &c__34, &c__3, &c__0, &c__1, &mxord, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L750; -L704: - s_copy(msg, "DASPK-- RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS LRW (=I2)" - , (ftnlen)80, (ftnlen)60); - xerrwd_(msg, &c__60, &c__4, &c__0, &c__2, &lenrw, lrw, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L750; -L705: - s_copy(msg, "DASPK-- IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS LIW (=I2)" - , (ftnlen)80, (ftnlen)60); - xerrwd_(msg, &c__60, &c__5, &c__0, &c__2, &leniw, liw, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L750; -L706: - s_copy(msg, "DASPK-- SOME ELEMENT OF RTOL IS .LT. 0", (ftnlen)80, ( - ftnlen)39); - xerrwd_(msg, &c__39, &c__6, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L750; -L707: - s_copy(msg, "DASPK-- SOME ELEMENT OF ATOL IS .LT. 0", (ftnlen)80, ( - ftnlen)39); - xerrwd_(msg, &c__39, &c__7, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L750; -L708: - s_copy(msg, "DASPK-- ALL ELEMENTS OF RTOL AND ATOL ARE ZERO", (ftnlen)80, - (ftnlen)47); - xerrwd_(msg, &c__47, &c__8, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L750; -L709: - s_copy(msg, "DASPK-- INFO(4) = 1 AND TSTOP (=R1) BEHIND TOUT (=R2)", ( - ftnlen)80, (ftnlen)54); - xerrwd_(msg, &c__54, &c__9, &c__0, &c__0, &c__0, &c__0, &c__2, &tstop, - tout, (ftnlen)80); - goto L750; -L710: - s_copy(msg, "DASPK-- HMAX (=R1) .LT. 0.0", (ftnlen)80, (ftnlen)28); - xerrwd_(msg, &c__28, &c__10, &c__0, &c__0, &c__0, &c__0, &c__1, &hmax, & - c_b37, (ftnlen)80); - goto L750; -L711: - s_copy(msg, "DASPK-- TOUT (=R1) BEHIND T (=R2)", (ftnlen)80, (ftnlen)34); - xerrwd_(msg, &c__34, &c__11, &c__0, &c__0, &c__0, &c__0, &c__2, tout, t, ( - ftnlen)80); - goto L750; -L712: - s_copy(msg, "DASPK-- INFO(8)=1 AND H0=0.0", (ftnlen)80, (ftnlen)29); - xerrwd_(msg, &c__29, &c__12, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L750; -L713: - s_copy(msg, "DASPK-- SOME ELEMENT OF WT IS .LE. 0.0", (ftnlen)80, ( - ftnlen)39); - xerrwd_(msg, &c__39, &c__13, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L750; -L714: - s_copy(msg, "DASPK-- TOUT (=R1) TOO CLOSE TO T (=R2) TO START INTEGRATION" - , (ftnlen)80, (ftnlen)60); - xerrwd_(msg, &c__60, &c__14, &c__0, &c__0, &c__0, &c__0, &c__2, tout, t, ( - ftnlen)80); - goto L750; -L715: - s_copy(msg, "DASPK-- INFO(4)=1 AND TSTOP (=R1) BEHIND T (=R2)", (ftnlen) - 80, (ftnlen)49); - xerrwd_(msg, &c__49, &c__15, &c__0, &c__0, &c__0, &c__0, &c__2, &tstop, t, - (ftnlen)80); - goto L750; -L717: - s_copy(msg, "DASPK-- ML (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ", ( - ftnlen)80, (ftnlen)52); - xerrwd_(msg, &c__52, &c__17, &c__0, &c__1, &iwork[1], &c__0, &c__0, & - c_b37, &c_b37, (ftnlen)80); - goto L750; -L718: - s_copy(msg, "DASPK-- MU (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ", ( - ftnlen)80, (ftnlen)52); - xerrwd_(msg, &c__52, &c__18, &c__0, &c__1, &iwork[2], &c__0, &c__0, & - c_b37, &c_b37, (ftnlen)80); - goto L750; -L719: - s_copy(msg, "DASPK-- TOUT (=R1) IS EQUAL TO T (=R2)", (ftnlen)80, ( - ftnlen)39); - xerrwd_(msg, &c__39, &c__19, &c__0, &c__0, &c__0, &c__0, &c__2, tout, t, ( - ftnlen)80); - goto L750; -L720: - s_copy(msg, "DASPK-- MAXL (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. NEQ", ( - ftnlen)80, (ftnlen)54); - xerrwd_(msg, &c__54, &c__20, &c__0, &c__1, &iwork[24], &c__0, &c__0, & - c_b37, &c_b37, (ftnlen)80); - goto L750; -L721: - s_copy(msg, "DASPK-- KMP (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. MAXL", ( - ftnlen)80, (ftnlen)54); - xerrwd_(msg, &c__54, &c__21, &c__0, &c__1, &iwork[25], &c__0, &c__0, & - c_b37, &c_b37, (ftnlen)80); - goto L750; -L722: - s_copy(msg, "DASPK-- NRMAX (=I1) ILLEGAL. .LT. 0", (ftnlen)80, (ftnlen) - 36); - xerrwd_(msg, &c__36, &c__22, &c__0, &c__1, &iwork[26], &c__0, &c__0, & - c_b37, &c_b37, (ftnlen)80); - goto L750; -L723: - s_copy(msg, "DASPK-- EPLI (=R1) ILLEGAL. EITHER .LE. 0.D0 OR .GE. 1.D0", - (ftnlen)80, (ftnlen)58); - xerrwd_(msg, &c__58, &c__23, &c__0, &c__0, &c__0, &c__0, &c__1, &rwork[10] - , &c_b37, (ftnlen)80); - goto L750; -L724: - s_copy(msg, "DASPK-- ILLEGAL IWORK VALUE FOR INFO(11) .NE. 0", (ftnlen) - 80, (ftnlen)48); - xerrwd_(msg, &c__48, &c__24, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L750; -L725: - s_copy(msg, "DASPK-- ONE OF THE INPUTS FOR INFO(17) = 1 IS ILLEGAL", ( - ftnlen)80, (ftnlen)54); - xerrwd_(msg, &c__54, &c__25, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L750; -L726: - s_copy(msg, "DASPK-- ILLEGAL IWORK VALUE FOR INFO(10) .NE. 0", (ftnlen) - 80, (ftnlen)48); - xerrwd_(msg, &c__48, &c__26, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L750; -L727: - s_copy(msg, "DASPK-- Y(I) AND IWORK(40+I) (I=I1) INCONSISTENT", (ftnlen) - 80, (ftnlen)49); - xerrwd_(msg, &c__49, &c__27, &c__0, &c__1, &iret, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - goto L750; -L750: - if (info[1] == -1) { - goto L760; - } - info[1] = -1; - *idid = -33; - return 0; -L760: - s_copy(msg, "DASPK-- REPEATED OCCURRENCES OF ILLEGAL INPUT", (ftnlen)80, - (ftnlen)46); - xerrwd_(msg, &c__46, &c__701, &c__0, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); -/* L770: */ - s_copy(msg, "DASPK-- RUN TERMINATED. APPARENT INFINITE LOOP", (ftnlen)80, - (ftnlen)47); - xerrwd_(msg, &c__47, &c__702, &c__1, &c__0, &c__0, &c__0, &c__0, &c_b37, & - c_b37, (ftnlen)80); - return 0; - -/* ------END OF SUBROUTINE DDASPK----------------------------------------- */ -} /* ddaspk_ */ - -/* Subroutine */ int ddasic_(doublereal *x, doublereal *y, doublereal *yprime, - integer *neq, integer *icopt, integer *id, U_fp res, U_fp jac, U_fp - psol, doublereal *h__, doublereal *tscale, doublereal *wt, integer * - nic, integer *idid, doublereal *rpar, integer *ipar, doublereal *phi, - doublereal *savr, doublereal *delta, doublereal *e, doublereal *yic, - doublereal *ypic, doublereal *pwk, doublereal *wm, integer *iwm, - doublereal *uround, doublereal *epli, doublereal *sqrtn, doublereal * - rsqrtn, doublereal *epconi, doublereal *stptol, integer *jflg, - integer *icnflg, integer *icnstr, S_fp nlsic) -{ - /* Initialized data */ - - static doublereal rhcut = .1; - static doublereal ratemx = .8; - - /* System generated locals */ - integer phi_dim1, phi_offset; - - /* Local variables */ - doublereal cj; - integer nh, mxnh; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); - integer jskip, iernls; - - -/* ***BEGIN PROLOGUE DDASIC */ -/* ***REFER TO DDASPK */ -/* ***DATE WRITTEN 940628 (YYMMDD) */ -/* ***REVISION DATE 941206 (YYMMDD) */ -/* ***REVISION DATE 950714 (YYMMDD) */ -/* ***REVISION DATE 000628 TSCALE argument added. */ - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* DDASIC is a driver routine to compute consistent initial values */ -/* for Y and YPRIME. There are two different options: */ -/* Denoting the differential variables in Y by Y_d, and */ -/* the algebraic variables by Y_a, the problem solved is either: */ -/* 1. Given Y_d, calculate Y_a and Y_d', or */ -/* 2. Given Y', calculate Y. */ -/* In either case, initial values for the given components */ -/* are input, and initial guesses for the unknown components */ -/* must also be provided as input. */ - -/* The external routine NLSIC solves the resulting nonlinear system. */ - -/* The parameters represent */ - -/* X -- Independent variable. */ -/* Y -- Solution vector at X. */ -/* YPRIME -- Derivative of solution vector. */ -/* NEQ -- Number of equations to be integrated. */ -/* ICOPT -- Flag indicating initial condition option chosen. */ -/* ICOPT = 1 for option 1 above. */ -/* ICOPT = 2 for option 2. */ -/* ID -- Array of dimension NEQ, which must be initialized */ -/* if option 1 is chosen. */ -/* ID(i) = +1 if Y_i is a differential variable, */ -/* ID(i) = -1 if Y_i is an algebraic variable. */ -/* RES -- External user-supplied subroutine to evaluate the */ -/* residual. See RES description in DDASPK prologue. */ -/* JAC -- External user-supplied routine to update Jacobian */ -/* or preconditioner information in the nonlinear solver */ -/* (optional). See JAC description in DDASPK prologue. */ -/* PSOL -- External user-supplied routine to solve */ -/* a linear system using preconditioning. */ -/* See PSOL in DDASPK prologue. */ -/* H -- Scaling factor in iteration matrix. DDASIC may */ -/* reduce H to achieve convergence. */ -/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ -/* WT -- Vector of weights for error criterion. */ -/* NIC -- Input number of initial condition calculation call */ -/* (= 1 or 2). */ -/* IDID -- Completion code. See IDID in DDASPK prologue. */ -/* RPAR,IPAR -- Real and integer parameter arrays that */ -/* are used for communication between the */ -/* calling program and external user routines. */ -/* They are not altered by DNSK */ -/* PHI -- Work space for DDASIC of length at least 2*NEQ. */ -/* SAVR -- Work vector for DDASIC of length NEQ. */ -/* DELTA -- Work vector for DDASIC of length NEQ. */ -/* E -- Work vector for DDASIC of length NEQ. */ -/* YIC,YPIC -- Work vectors for DDASIC, each of length NEQ. */ -/* PWK -- Work vector for DDASIC of length NEQ. */ -/* WM,IWM -- Real and integer arrays storing */ -/* information required by the linear solver. */ -/* EPCONI -- Test constant for Newton iteration convergence. */ -/* ICNFLG -- Flag showing whether constraints on Y are to apply. */ -/* ICNSTR -- Integer array of length NEQ with constraint types. */ - -/* The other parameters are for use internally by DDASIC. */ - -/* ----------------------------------------------------------------------- */ -/* ***ROUTINES CALLED */ -/* DCOPY, NLSIC */ - -/* ***END PROLOGUE DDASIC */ - - - - -/* The following parameters are data-loaded here: */ -/* RHCUT = factor by which H is reduced on retry of Newton solve. */ -/* RATEMX = maximum convergence rate for which Newton iteration */ -/* is considered converging. */ - - /* Parameter adjustments */ - --y; - --yprime; - phi_dim1 = *neq; - phi_offset = 1 + phi_dim1; - phi -= phi_offset; - --id; - --wt; - --rpar; - --ipar; - --savr; - --delta; - --e; - --yic; - --ypic; - --pwk; - --wm; - --iwm; - --icnstr; - - /* Function Body */ - - -/* ----------------------------------------------------------------------- */ -/* BLOCK 1. */ -/* Initializations. */ -/* JSKIP is a flag set to 1 when NIC = 2 and NH = 1, to signal that */ -/* the initial call to the JAC routine is to be skipped then. */ -/* Save Y and YPRIME in PHI. Initialize IDID, NH, and CJ. */ -/* ----------------------------------------------------------------------- */ - - mxnh = iwm[34]; - *idid = 1; - nh = 1; - jskip = 0; - if (*nic == 2) { - jskip = 1; - } - dcopy_(neq, &y[1], &c__1, &phi[phi_dim1 + 1], &c__1); - dcopy_(neq, &yprime[1], &c__1, &phi[(phi_dim1 << 1) + 1], &c__1); - - if (*icopt == 2) { - cj = 0.; - } else { - cj = 1. / *h__; - } - -/* ----------------------------------------------------------------------- */ -/* BLOCK 2 */ -/* Call the nonlinear system solver to obtain */ -/* consistent initial values for Y and YPRIME. */ -/* ----------------------------------------------------------------------- */ - -L200: - (*nlsic)(x, &y[1], &yprime[1], neq, icopt, &id[1], (U_fp)res, (U_fp)jac, ( - U_fp)psol, h__, tscale, &wt[1], &jskip, &rpar[1], &ipar[1], &savr[ - 1], &delta[1], &e[1], &yic[1], &ypic[1], &pwk[1], &wm[1], &iwm[1], - &cj, uround, epli, sqrtn, rsqrtn, epconi, &ratemx, stptol, jflg, - icnflg, &icnstr[1], &iernls); - - if (iernls == 0) { - return 0; - } - -/* ----------------------------------------------------------------------- */ -/* BLOCK 3 */ -/* The nonlinear solver was unsuccessful. Increment NCFN. */ -/* Return with IDID = -12 if either */ -/* IERNLS = -1: error is considered unrecoverable, */ -/* ICOPT = 2: we are doing initialization problem type 2, or */ -/* NH = MXNH: the maximum number of H values has been tried. */ -/* Otherwise (problem 1 with IERNLS .GE. 1), reduce H and try again. */ -/* If IERNLS > 1, restore Y and YPRIME to their original values. */ -/* ----------------------------------------------------------------------- */ - - ++iwm[15]; - jskip = 0; - - if (iernls == -1) { - goto L350; - } - if (*icopt == 2) { - goto L350; - } - if (nh == mxnh) { - goto L350; - } - - ++nh; - *h__ *= rhcut; - cj = 1. / *h__; - - if (iernls == 1) { - goto L200; - } - - dcopy_(neq, &phi[phi_dim1 + 1], &c__1, &y[1], &c__1); - dcopy_(neq, &phi[(phi_dim1 << 1) + 1], &c__1, &yprime[1], &c__1); - goto L200; - -L350: - *idid = -12; - return 0; - -/* ------END OF SUBROUTINE DDASIC----------------------------------------- */ -} /* ddasic_ */ - -/* Subroutine */ int dyypnw_(integer *neq, doublereal *y, doublereal *yprime, - doublereal *cj, doublereal *rl, doublereal *p, integer *icopt, - integer *id, doublereal *ynew, doublereal *ypnew) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__; - - -/* ***BEGIN PROLOGUE DYYPNW */ -/* ***REFER TO DLINSK */ -/* ***DATE WRITTEN 940830 (YYMMDD) */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* DYYPNW calculates the new (Y,YPRIME) pair needed in the */ -/* linesearch algorithm based on the current lambda value. It is */ -/* called by DLINSK and DLINSD. Based on the ICOPT and ID values, */ -/* the corresponding entry in Y or YPRIME is updated. */ - -/* In addition to the parameters described in the calling programs, */ -/* the parameters represent */ - -/* P -- Array of length NEQ that contains the current */ -/* approximate Newton step. */ -/* RL -- Scalar containing the current lambda value. */ -/* YNEW -- Array of length NEQ containing the updated Y vector. */ -/* YPNEW -- Array of length NEQ containing the updated YPRIME */ -/* vector. */ -/* ----------------------------------------------------------------------- */ - -/* ***ROUTINES CALLED (NONE) */ - -/* ***END PROLOGUE DYYPNW */ - - - - /* Parameter adjustments */ - --ypnew; - --ynew; - --id; - --p; - --yprime; - --y; - - /* Function Body */ - if (*icopt == 1) { - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - if (id[i__] < 0) { - ynew[i__] = y[i__] - *rl * p[i__]; - ypnew[i__] = yprime[i__]; - } else { - ynew[i__] = y[i__]; - ypnew[i__] = yprime[i__] - *rl * *cj * p[i__]; - } -/* L10: */ - } - } else { - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - ynew[i__] = y[i__] - *rl * p[i__]; - ypnew[i__] = yprime[i__]; -/* L20: */ - } - } - return 0; -/* ----------------------- END OF SUBROUTINE DYYPNW ---------------------- */ -} /* dyypnw_ */ - -/* Subroutine */ int ddstp_(doublereal *x, doublereal *y, doublereal *yprime, - integer *neq, U_fp res, U_fp jac, U_fp psol, doublereal *h__, - doublereal *wt, doublereal *vt, integer *jstart, integer *idid, - doublereal *rpar, integer *ipar, doublereal *phi, doublereal *savr, - doublereal *delta, doublereal *e, doublereal *wm, integer *iwm, - doublereal *alpha, doublereal *beta, doublereal *gamma, doublereal * - psi, doublereal *sigma, doublereal *cj, doublereal *cjold, doublereal - *hold, doublereal *s, doublereal *hmin, doublereal *uround, - doublereal *epli, doublereal *sqrtn, doublereal *rsqrtn, doublereal * - epcon, integer *iphase, integer *jcalc, integer *jflg, integer *k, - integer *kold, integer *ns, integer *nonneg, integer *ntype, S_fp nls) -{ - /* System generated locals */ - integer phi_dim1, phi_offset, i__1, i__2; - doublereal d__1, d__2; - - /* Builtin functions */ - double pow_dd(doublereal *, doublereal *); - - /* Local variables */ - integer i__, j; - doublereal r__; - integer j1; - doublereal ck; - integer km1, kp1, kp2, ncf, nef; - doublereal erk, err, est; - integer nsp1; - doublereal hnew, terk, xold; - integer knew; - doublereal erkm1, erkm2, erkp1, temp1, temp2; - integer kdiff; - doublereal enorm, alpha0, terkm1, terkm2, terkp1, alphas; - extern /* Subroutine */ int ddatrp_(doublereal *, doublereal *, - doublereal *, doublereal *, integer *, integer *, doublereal *, - doublereal *); - doublereal cjlast; - extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, - doublereal *, integer *); - integer iernls; - - -/* ***BEGIN PROLOGUE DDSTP */ -/* ***REFER TO DDASPK */ -/* ***DATE WRITTEN 890101 (YYMMDD) */ -/* ***REVISION DATE 900926 (YYMMDD) */ -/* ***REVISION DATE 940909 (YYMMDD) (Reset PSI(1), PHI(*,2) at 690) */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* DDSTP solves a system of differential/algebraic equations of */ -/* the form G(X,Y,YPRIME) = 0, for one step (normally from X to X+H). */ - -/* The methods used are modified divided difference, fixed leading */ -/* coefficient forms of backward differentiation formulas. */ -/* The code adjusts the stepsize and order to control the local error */ -/* per step. */ - - -/* The parameters represent */ -/* X -- Independent variable. */ -/* Y -- Solution vector at X. */ -/* YPRIME -- Derivative of solution vector */ -/* after successful step. */ -/* NEQ -- Number of equations to be integrated. */ -/* RES -- External user-supplied subroutine */ -/* to evaluate the residual. See RES description */ -/* in DDASPK prologue. */ -/* JAC -- External user-supplied routine to update */ -/* Jacobian or preconditioner information in the */ -/* nonlinear solver. See JAC description in DDASPK */ -/* prologue. */ -/* PSOL -- External user-supplied routine to solve */ -/* a linear system using preconditioning. */ -/* (This is optional). See PSOL in DDASPK prologue. */ -/* H -- Appropriate step size for next step. */ -/* Normally determined by the code. */ -/* WT -- Vector of weights for error criterion used in Newton test. */ -/* VT -- Masked vector of weights used in error test. */ -/* JSTART -- Integer variable set 0 for */ -/* first step, 1 otherwise. */ -/* IDID -- Completion code returned from the nonlinear solver. */ -/* See IDID description in DDASPK prologue. */ -/* RPAR,IPAR -- Real and integer parameter arrays that */ -/* are used for communication between the */ -/* calling program and external user routines. */ -/* They are not altered by DNSK */ -/* PHI -- Array of divided differences used by */ -/* DDSTP. The length is NEQ*(K+1), where */ -/* K is the maximum order. */ -/* SAVR -- Work vector for DDSTP of length NEQ. */ -/* DELTA,E -- Work vectors for DDSTP of length NEQ. */ -/* WM,IWM -- Real and integer arrays storing */ -/* information required by the linear solver. */ - -/* The other parameters are information */ -/* which is needed internally by DDSTP to */ -/* continue from step to step. */ - -/* ----------------------------------------------------------------------- */ -/* ***ROUTINES CALLED */ -/* NLS, DDWNRM, DDATRP */ - -/* ***END PROLOGUE DDSTP */ - - - - - -/* ----------------------------------------------------------------------- */ -/* BLOCK 1. */ -/* Initialize. On the first call, set */ -/* the order to 1 and initialize */ -/* other variables. */ -/* ----------------------------------------------------------------------- */ - -/* Initializations for all calls */ - - /* Parameter adjustments */ - --y; - --yprime; - phi_dim1 = *neq; - phi_offset = 1 + phi_dim1; - phi -= phi_offset; - --wt; - --vt; - --rpar; - --ipar; - --savr; - --delta; - --e; - --wm; - --iwm; - --alpha; - --beta; - --gamma; - --psi; - --sigma; - - /* Function Body */ - xold = *x; - ncf = 0; - nef = 0; - if (*jstart != 0) { - goto L120; - } - -/* If this is the first step, perform */ -/* other initializations */ - - *k = 1; - *kold = 0; - *hold = 0.; - psi[1] = *h__; - *cj = 1. / *h__; - *iphase = 0; - *ns = 0; -L120: - - - - - -/* ----------------------------------------------------------------------- */ -/* BLOCK 2 */ -/* Compute coefficients of formulas for */ -/* this step. */ -/* ----------------------------------------------------------------------- */ -L200: - kp1 = *k + 1; - kp2 = *k + 2; - km1 = *k - 1; - if (*h__ != *hold || *k != *kold) { - *ns = 0; - } -/* Computing MIN */ - i__1 = *ns + 1, i__2 = *kold + 2; - *ns = min(i__1,i__2); - nsp1 = *ns + 1; - if (kp1 < *ns) { - goto L230; - } - - beta[1] = 1.; - alpha[1] = 1.; - temp1 = *h__; - gamma[1] = 0.; - sigma[1] = 1.; - i__1 = kp1; - for (i__ = 2; i__ <= i__1; ++i__) { - temp2 = psi[i__ - 1]; - psi[i__ - 1] = temp1; - beta[i__] = beta[i__ - 1] * psi[i__ - 1] / temp2; - temp1 = temp2 + *h__; - alpha[i__] = *h__ / temp1; - sigma[i__] = (i__ - 1) * sigma[i__ - 1] * alpha[i__]; - gamma[i__] = gamma[i__ - 1] + alpha[i__ - 1] / *h__; -/* L210: */ - } - psi[kp1] = temp1; -L230: - -/* Compute ALPHAS, ALPHA0 */ - - alphas = 0.; - alpha0 = 0.; - i__1 = *k; - for (i__ = 1; i__ <= i__1; ++i__) { - alphas -= 1. / i__; - alpha0 -= alpha[i__]; -/* L240: */ - } - -/* Compute leading coefficient CJ */ - - cjlast = *cj; - *cj = -alphas / *h__; - -/* Compute variable stepsize error coefficient CK */ - - ck = (d__1 = alpha[kp1] + alphas - alpha0, abs(d__1)); -/* Computing MAX */ - d__1 = ck, d__2 = alpha[kp1]; - ck = max(d__1,d__2); - -/* Change PHI to PHI STAR */ - - if (kp1 < nsp1) { - goto L280; - } - i__1 = kp1; - for (j = nsp1; j <= i__1; ++j) { - i__2 = *neq; - for (i__ = 1; i__ <= i__2; ++i__) { -/* L260: */ - phi[i__ + j * phi_dim1] = beta[j] * phi[i__ + j * phi_dim1]; - } -/* L270: */ - } -L280: - -/* Update time */ - - *x += *h__; - -/* Initialize IDID to 1 */ - - *idid = 1; - - - - - -/* ----------------------------------------------------------------------- */ -/* BLOCK 3 */ -/* Call the nonlinear system solver to obtain the solution and */ -/* derivative. */ -/* ----------------------------------------------------------------------- */ - - (*nls)(x, &y[1], &yprime[1], neq, (U_fp)res, (U_fp)jac, (U_fp)psol, h__, & - wt[1], jstart, idid, &rpar[1], &ipar[1], &phi[phi_offset], &gamma[ - 1], &savr[1], &delta[1], &e[1], &wm[1], &iwm[1], cj, cjold, & - cjlast, s, uround, epli, sqrtn, rsqrtn, epcon, jcalc, jflg, &kp1, - nonneg, ntype, &iernls); - - if (iernls != 0) { - goto L600; - } - - - - - -/* ----------------------------------------------------------------------- */ -/* BLOCK 4 */ -/* Estimate the errors at orders K,K-1,K-2 */ -/* as if constant stepsize was used. Estimate */ -/* the local error at order K and test */ -/* whether the current step is successful. */ -/* ----------------------------------------------------------------------- */ - -/* Estimate errors at orders K,K-1,K-2 */ - - enorm = ddwnrm_(neq, &e[1], &vt[1], &rpar[1], &ipar[1]); - erk = sigma[*k + 1] * enorm; - terk = (*k + 1) * erk; - est = erk; - knew = *k; - if (*k == 1) { - goto L430; - } - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L405: */ - delta[i__] = phi[i__ + kp1 * phi_dim1] + e[i__]; - } - erkm1 = sigma[*k] * ddwnrm_(neq, &delta[1], &vt[1], &rpar[1], &ipar[1]); - terkm1 = *k * erkm1; - if (*k > 2) { - goto L410; - } - if (terkm1 <= terk * .5f) { - goto L420; - } - goto L430; -L410: - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L415: */ - delta[i__] = phi[i__ + *k * phi_dim1] + delta[i__]; - } - erkm2 = sigma[*k - 1] * ddwnrm_(neq, &delta[1], &vt[1], &rpar[1], &ipar[1] - ); - terkm2 = (*k - 1) * erkm2; - if (max(terkm1,terkm2) > terk) { - goto L430; - } - -/* Lower the order */ - -L420: - knew = *k - 1; - est = erkm1; - - -/* Calculate the local error for the current step */ -/* to see if the step was successful */ - -L430: - err = ck * enorm; - if (err > 1.) { - goto L600; - } - - - - - -/* ----------------------------------------------------------------------- */ -/* BLOCK 5 */ -/* The step is successful. Determine */ -/* the best order and stepsize for */ -/* the next step. Update the differences */ -/* for the next step. */ -/* ----------------------------------------------------------------------- */ - *idid = 1; - ++iwm[11]; - kdiff = *k - *kold; - *kold = *k; - *hold = *h__; - - -/* Estimate the error at order K+1 unless */ -/* already decided to lower order, or */ -/* already using maximum order, or */ -/* stepsize not constant, or */ -/* order raised in previous step */ - - if (knew == km1 || *k == iwm[3]) { - *iphase = 1; - } - if (*iphase == 0) { - goto L545; - } - if (knew == km1) { - goto L540; - } - if (*k == iwm[3]) { - goto L550; - } - if (kp1 >= *ns || kdiff == 1) { - goto L550; - } - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L510: */ - delta[i__] = e[i__] - phi[i__ + kp2 * phi_dim1]; - } - erkp1 = 1. / (*k + 2) * ddwnrm_(neq, &delta[1], &vt[1], &rpar[1], &ipar[1] - ); - terkp1 = (*k + 2) * erkp1; - if (*k > 1) { - goto L520; - } - if (terkp1 >= terk * .5) { - goto L550; - } - goto L530; -L520: - if (terkm1 <= min(terk,terkp1)) { - goto L540; - } - if (terkp1 >= terk || *k == iwm[3]) { - goto L550; - } - -/* Raise order */ - -L530: - *k = kp1; - est = erkp1; - goto L550; - -/* Lower order */ - -L540: - *k = km1; - est = erkm1; - goto L550; - -/* If IPHASE = 0, increase order by one and multiply stepsize by */ -/* factor two */ - -L545: - *k = kp1; - hnew = *h__ * 2.; - *h__ = hnew; - goto L575; - - -/* Determine the appropriate stepsize for */ -/* the next step. */ - -L550: - hnew = *h__; - temp2 = (doublereal) (*k + 1); - d__1 = est * 2. + 1e-4; - d__2 = -1. / temp2; - r__ = pow_dd(&d__1, &d__2); - if (r__ < 2.) { - goto L555; - } - hnew = *h__ * 2.; - goto L560; -L555: - if (r__ > 1.) { - goto L560; - } -/* Computing MAX */ - d__1 = .5, d__2 = min(.9,r__); - r__ = max(d__1,d__2); - hnew = *h__ * r__; -L560: - *h__ = hnew; - - -/* Update differences for next step */ - -L575: - if (*kold == iwm[3]) { - goto L585; - } - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L580: */ - phi[i__ + kp2 * phi_dim1] = e[i__]; - } -L585: - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L590: */ - phi[i__ + kp1 * phi_dim1] += e[i__]; - } - i__1 = kp1; - for (j1 = 2; j1 <= i__1; ++j1) { - j = kp1 - j1 + 1; - i__2 = *neq; - for (i__ = 1; i__ <= i__2; ++i__) { -/* L595: */ - phi[i__ + j * phi_dim1] += phi[i__ + (j + 1) * phi_dim1]; - } - } - *jstart = 1; - return 0; - - - - - -/* ----------------------------------------------------------------------- */ -/* BLOCK 6 */ -/* The step is unsuccessful. Restore X,PSI,PHI */ -/* Determine appropriate stepsize for */ -/* continuing the integration, or exit with */ -/* an error flag if there have been many */ -/* failures. */ -/* ----------------------------------------------------------------------- */ -L600: - *iphase = 1; - -/* Restore X,PHI,PSI */ - - *x = xold; - if (kp1 < nsp1) { - goto L630; - } - i__2 = kp1; - for (j = nsp1; j <= i__2; ++j) { - temp1 = 1. / beta[j]; - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L610: */ - phi[i__ + j * phi_dim1] = temp1 * phi[i__ + j * phi_dim1]; - } -/* L620: */ - } -L630: - i__2 = kp1; - for (i__ = 2; i__ <= i__2; ++i__) { -/* L640: */ - psi[i__ - 1] = psi[i__] - *h__; - } - - -/* Test whether failure is due to nonlinear solver */ -/* or error test */ - - if (iernls == 0) { - goto L660; - } - ++iwm[15]; - - -/* The nonlinear solver failed to converge. */ -/* Determine the cause of the failure and take appropriate action. */ -/* If IERNLS .LT. 0, then return. Otherwise, reduce the stepsize */ -/* and try again, unless too many failures have occurred. */ - - if (iernls < 0) { - goto L675; - } - ++ncf; - r__ = .25; - *h__ *= r__; - if (ncf < 10 && abs(*h__) >= *hmin) { - goto L690; - } - if (*idid == 1) { - *idid = -7; - } - if (nef >= 3) { - *idid = -9; - } - goto L675; - - -/* The nonlinear solver converged, and the cause */ -/* of the failure was the error estimate */ -/* exceeding the tolerance. */ - -L660: - ++nef; - ++iwm[14]; - if (nef > 1) { - goto L665; - } - -/* On first error test failure, keep current order or lower */ -/* order by one. Compute new stepsize based on differences */ -/* of the solution. */ - - *k = knew; - temp2 = (doublereal) (*k + 1); - d__1 = est * 2. + 1e-4; - d__2 = -1. / temp2; - r__ = pow_dd(&d__1, &d__2) * .9; -/* Computing MAX */ - d__1 = .25, d__2 = min(.9,r__); - r__ = max(d__1,d__2); - *h__ *= r__; - if (abs(*h__) >= *hmin) { - goto L690; - } - *idid = -6; - goto L675; - -/* On second error test failure, use the current order or */ -/* decrease order by one. Reduce the stepsize by a factor of */ -/* one quarter. */ - -L665: - if (nef > 2) { - goto L670; - } - *k = knew; - r__ = .25; - *h__ = r__ * *h__; - if (abs(*h__) >= *hmin) { - goto L690; - } - *idid = -6; - goto L675; - -/* On third and subsequent error test failures, set the order to */ -/* one, and reduce the stepsize by a factor of one quarter. */ - -L670: - *k = 1; - r__ = .25; - *h__ = r__ * *h__; - if (abs(*h__) >= *hmin) { - goto L690; - } - *idid = -6; - goto L675; - - - - -/* For all crashes, restore Y to its last value, */ -/* interpolate to find YPRIME at last X, and return. */ - -/* Before returning, verify that the user has not set */ -/* IDID to a nonnegative value. If the user has set IDID */ -/* to a nonnegative value, then reset IDID to be -7, indicating */ -/* a failure in the nonlinear system solver. */ - -L675: - ddatrp_(x, x, &y[1], &yprime[1], neq, k, &phi[phi_offset], &psi[1]); - *jstart = 1; - if (*idid >= 0) { - *idid = -7; - } - return 0; - - -/* Go back and try this step again. */ -/* If this is the first step, reset PSI(1) and rescale PHI(*,2). */ - -L690: - if (*kold == 0) { - psi[1] = *h__; - i__2 = *neq; - for (i__ = 1; i__ <= i__2; ++i__) { -/* L695: */ - phi[i__ + (phi_dim1 << 1)] = r__ * phi[i__ + (phi_dim1 << 1)]; - } - } - goto L200; - -/* ------END OF SUBROUTINE DDSTP------------------------------------------ */ -} /* ddstp_ */ - -/* Subroutine */ int dcnstr_(integer *neq, doublereal *y, doublereal *ynew, - integer *icnstr, doublereal *tau, doublereal *rlx, integer *iret, - integer *ivar) -{ - /* Initialized data */ - - static doublereal fac = .6; - static doublereal fac2 = .9; - static doublereal zero = 0.; - - /* System generated locals */ - integer i__1; - doublereal d__1; - - /* Local variables */ - integer i__; - doublereal rdy, rdymx; - - -/* ***BEGIN PROLOGUE DCNSTR */ -/* ***DATE WRITTEN 950808 (YYMMDD) */ -/* ***REVISION DATE 950814 (YYMMDD) */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* This subroutine checks for constraint violations in the proposed */ -/* new approximate solution YNEW. */ -/* If a constraint violation occurs, then a new step length, TAU, */ -/* is calculated, and this value is to be given to the linesearch routine */ -/* to calculate a new approximate solution YNEW. */ - -/* On entry: */ - -/* NEQ -- size of the nonlinear system, and the length of arrays */ -/* Y, YNEW and ICNSTR. */ - -/* Y -- real array containing the current approximate y. */ - -/* YNEW -- real array containing the new approximate y. */ - -/* ICNSTR -- INTEGER array of length NEQ containing flags indicating */ -/* which entries in YNEW are to be constrained. */ -/* if ICNSTR(I) = 2, then YNEW(I) must be .GT. 0, */ -/* if ICNSTR(I) = 1, then YNEW(I) must be .GE. 0, */ -/* if ICNSTR(I) = -1, then YNEW(I) must be .LE. 0, while */ -/* if ICNSTR(I) = -2, then YNEW(I) must be .LT. 0, while */ -/* if ICNSTR(I) = 0, then YNEW(I) is not constrained. */ - -/* RLX -- real scalar restricting update, if ICNSTR(I) = 2 or -2, */ -/* to ABS( (YNEW-Y)/Y ) < FAC2*RLX in component I. */ - -/* TAU -- the current size of the step length for the linesearch. */ - -/* On return */ - -/* TAU -- the adjusted size of the step length if a constraint */ -/* violation occurred (otherwise, it is unchanged). it is */ -/* the step length to give to the linesearch routine. */ - -/* IRET -- output flag. */ -/* IRET=0 means that YNEW satisfied all constraints. */ -/* IRET=1 means that YNEW failed to satisfy all the */ -/* constraints, and a new linesearch step */ -/* must be computed. */ - -/* IVAR -- index of variable causing constraint to be violated. */ - -/* ----------------------------------------------------------------------- */ - /* Parameter adjustments */ - --icnstr; - --ynew; - --y; - - /* Function Body */ -/* ----------------------------------------------------------------------- */ -/* Check constraints for proposed new step YNEW. If a constraint has */ -/* been violated, then calculate a new step length, TAU, to be */ -/* used in the linesearch routine. */ -/* ----------------------------------------------------------------------- */ - *iret = 0; - rdymx = zero; - *ivar = 0; - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - - if (icnstr[i__] == 2) { - rdy = (d__1 = (ynew[i__] - y[i__]) / y[i__], abs(d__1)); - if (rdy > rdymx) { - rdymx = rdy; - *ivar = i__; - } - if (ynew[i__] <= zero) { - *tau = fac * *tau; - *ivar = i__; - *iret = 1; - return 0; - } - - } else if (icnstr[i__] == 1) { - if (ynew[i__] < zero) { - *tau = fac * *tau; - *ivar = i__; - *iret = 1; - return 0; - } - - } else if (icnstr[i__] == -1) { - if (ynew[i__] > zero) { - *tau = fac * *tau; - *ivar = i__; - *iret = 1; - return 0; - } - - } else if (icnstr[i__] == -2) { - rdy = (d__1 = (ynew[i__] - y[i__]) / y[i__], abs(d__1)); - if (rdy > rdymx) { - rdymx = rdy; - *ivar = i__; - } - if (ynew[i__] >= zero) { - *tau = fac * *tau; - *ivar = i__; - *iret = 1; - return 0; - } - - } -/* L100: */ - } - if (rdymx >= *rlx) { - *tau = fac2 * *tau * *rlx / rdymx; - *iret = 1; - } - - return 0; -/* ----------------------- END OF SUBROUTINE DCNSTR ---------------------- */ -} /* dcnstr_ */ - -/* Subroutine */ int dcnst0_(integer *neq, doublereal *y, integer *icnstr, - integer *iret) -{ - /* Initialized data */ - - static doublereal zero = 0.; - - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__; - - -/* ***BEGIN PROLOGUE DCNST0 */ -/* ***DATE WRITTEN 950808 (YYMMDD) */ -/* ***REVISION DATE 950808 (YYMMDD) */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* This subroutine checks for constraint violations in the initial */ -/* approximate solution u. */ - -/* On entry */ - -/* NEQ -- size of the nonlinear system, and the length of arrays */ -/* Y and ICNSTR. */ - -/* Y -- real array containing the initial approximate root. */ - -/* ICNSTR -- INTEGER array of length NEQ containing flags indicating */ -/* which entries in Y are to be constrained. */ -/* if ICNSTR(I) = 2, then Y(I) must be .GT. 0, */ -/* if ICNSTR(I) = 1, then Y(I) must be .GE. 0, */ -/* if ICNSTR(I) = -1, then Y(I) must be .LE. 0, while */ -/* if ICNSTR(I) = -2, then Y(I) must be .LT. 0, while */ -/* if ICNSTR(I) = 0, then Y(I) is not constrained. */ - -/* On return */ - -/* IRET -- output flag. */ -/* IRET=0 means that u satisfied all constraints. */ -/* IRET.NE.0 means that Y(IRET) failed to satisfy its */ -/* constraint. */ - -/* ----------------------------------------------------------------------- */ - /* Parameter adjustments */ - --icnstr; - --y; - - /* Function Body */ -/* ----------------------------------------------------------------------- */ -/* Check constraints for initial Y. If a constraint has been violated, */ -/* set IRET = I to signal an error return to calling routine. */ -/* ----------------------------------------------------------------------- */ - *iret = 0; - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - if (icnstr[i__] == 2) { - if (y[i__] <= zero) { - *iret = i__; - return 0; - } - } else if (icnstr[i__] == 1) { - if (y[i__] < zero) { - *iret = i__; - return 0; - } - } else if (icnstr[i__] == -1) { - if (y[i__] > zero) { - *iret = i__; - return 0; - } - } else if (icnstr[i__] == -2) { - if (y[i__] >= zero) { - *iret = i__; - return 0; - } - } -/* L100: */ - } - return 0; -/* ----------------------- END OF SUBROUTINE DCNST0 ---------------------- */ -} /* dcnst0_ */ - -/* Subroutine */ int ddawts_(integer *neq, integer *iwt, doublereal *rtol, - doublereal *atol, doublereal *y, doublereal *wt, doublereal *rpar, - integer *ipar) -{ - /* System generated locals */ - integer i__1; - doublereal d__1; - - /* Local variables */ - integer i__; - doublereal atoli, rtoli; - - -/* ***BEGIN PROLOGUE DDAWTS */ -/* ***REFER TO DDASPK */ -/* ***ROUTINES CALLED (NONE) */ -/* ***DATE WRITTEN 890101 (YYMMDD) */ -/* ***REVISION DATE 900926 (YYMMDD) */ -/* ***END PROLOGUE DDAWTS */ -/* ----------------------------------------------------------------------- */ -/* This subroutine sets the error weight vector, */ -/* WT, according to WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I), */ -/* I = 1 to NEQ. */ -/* RTOL and ATOL are scalars if IWT = 0, */ -/* and vectors if IWT = 1. */ -/* ----------------------------------------------------------------------- */ - - /* Parameter adjustments */ - --ipar; - --rpar; - --wt; - --y; - --atol; - --rtol; - - /* Function Body */ - rtoli = rtol[1]; - atoli = atol[1]; - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - if (*iwt == 0) { - goto L10; - } - rtoli = rtol[i__]; - atoli = atol[i__]; -L10: - wt[i__] = rtoli * (d__1 = y[i__], abs(d__1)) + atoli; -/* L20: */ - } - return 0; - -/* ------END OF SUBROUTINE DDAWTS----------------------------------------- */ -} /* ddawts_ */ - -/* Subroutine */ int dinvwt_(integer *neq, doublereal *wt, integer *ier) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__; - - -/* ***BEGIN PROLOGUE DINVWT */ -/* ***REFER TO DDASPK */ -/* ***ROUTINES CALLED (NONE) */ -/* ***DATE WRITTEN 950125 (YYMMDD) */ -/* ***END PROLOGUE DINVWT */ -/* ----------------------------------------------------------------------- */ -/* This subroutine checks the error weight vector WT, of length NEQ, */ -/* for components that are .le. 0, and if none are found, it */ -/* inverts the WT(I) in place. This replaces division operations */ -/* with multiplications in all norm evaluations. */ -/* IER is returned as 0 if all WT(I) were found positive, */ -/* and the first I with WT(I) .le. 0.0 otherwise. */ -/* ----------------------------------------------------------------------- */ - - - /* Parameter adjustments */ - --wt; - - /* Function Body */ - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - if (wt[i__] <= 0.) { - goto L30; - } -/* L10: */ - } - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L20: */ - wt[i__] = 1. / wt[i__]; - } - *ier = 0; - return 0; - -L30: - *ier = i__; - return 0; - -/* ------END OF SUBROUTINE DINVWT----------------------------------------- */ -} /* dinvwt_ */ - -/* Subroutine */ int ddatrp_(doublereal *x, doublereal *xout, doublereal * - yout, doublereal *ypout, integer *neq, integer *kold, doublereal *phi, - doublereal *psi) -{ - /* System generated locals */ - integer phi_dim1, phi_offset, i__1, i__2; - - /* Local variables */ - doublereal c__, d__; - integer i__, j; - doublereal temp1, gamma; - integer koldp1; - - -/* ***BEGIN PROLOGUE DDATRP */ -/* ***REFER TO DDASPK */ -/* ***ROUTINES CALLED (NONE) */ -/* ***DATE WRITTEN 890101 (YYMMDD) */ -/* ***REVISION DATE 900926 (YYMMDD) */ -/* ***END PROLOGUE DDATRP */ - -/* ----------------------------------------------------------------------- */ -/* The methods in subroutine DDSTP use polynomials */ -/* to approximate the solution. DDATRP approximates the */ -/* solution and its derivative at time XOUT by evaluating */ -/* one of these polynomials, and its derivative, there. */ -/* Information defining this polynomial is passed from */ -/* DDSTP, so DDATRP cannot be used alone. */ - -/* The parameters are */ - -/* X The current time in the integration. */ -/* XOUT The time at which the solution is desired. */ -/* YOUT The interpolated approximation to Y at XOUT. */ -/* (This is output.) */ -/* YPOUT The interpolated approximation to YPRIME at XOUT. */ -/* (This is output.) */ -/* NEQ Number of equations. */ -/* KOLD Order used on last successful step. */ -/* PHI Array of scaled divided differences of Y. */ -/* PSI Array of past stepsize history. */ -/* ----------------------------------------------------------------------- */ - - /* Parameter adjustments */ - --yout; - --ypout; - phi_dim1 = *neq; - phi_offset = 1 + phi_dim1; - phi -= phi_offset; - --psi; - - /* Function Body */ - koldp1 = *kold + 1; - temp1 = *xout - *x; - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - yout[i__] = phi[i__ + phi_dim1]; -/* L10: */ - ypout[i__] = 0.; - } - c__ = 1.; - d__ = 0.; - gamma = temp1 / psi[1]; - i__1 = koldp1; - for (j = 2; j <= i__1; ++j) { - d__ = d__ * gamma + c__ / psi[j - 1]; - c__ *= gamma; - gamma = (temp1 + psi[j - 1]) / psi[j]; - i__2 = *neq; - for (i__ = 1; i__ <= i__2; ++i__) { - yout[i__] += c__ * phi[i__ + j * phi_dim1]; -/* L20: */ - ypout[i__] += d__ * phi[i__ + j * phi_dim1]; - } -/* L30: */ - } - return 0; - -/* ------END OF SUBROUTINE DDATRP----------------------------------------- */ -} /* ddatrp_ */ - -doublereal ddwnrm_(integer *neq, doublereal *v, doublereal *rwt, doublereal * - rpar, integer *ipar) -{ - /* System generated locals */ - integer i__1; - doublereal ret_val, d__1, d__2; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__; - doublereal sum, vmax; - - -/* ***BEGIN PROLOGUE DDWNRM */ -/* ***ROUTINES CALLED (NONE) */ -/* ***DATE WRITTEN 890101 (YYMMDD) */ -/* ***REVISION DATE 900926 (YYMMDD) */ -/* ***END PROLOGUE DDWNRM */ -/* ----------------------------------------------------------------------- */ -/* This function routine computes the weighted */ -/* root-mean-square norm of the vector of length */ -/* NEQ contained in the array V, with reciprocal weights */ -/* contained in the array RWT of length NEQ. */ -/* DDWNRM=SQRT((1/NEQ)*SUM(V(I)*RWT(I))**2) */ -/* ----------------------------------------------------------------------- */ - - /* Parameter adjustments */ - --ipar; - --rpar; - --rwt; - --v; - - /* Function Body */ - ret_val = 0.; - vmax = 0.; - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - if ((d__1 = v[i__] * rwt[i__], abs(d__1)) > vmax) { - vmax = (d__2 = v[i__] * rwt[i__], abs(d__2)); - } -/* L10: */ - } - if (vmax <= 0.) { - goto L30; - } - sum = 0.; - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L20: */ -/* Computing 2nd power */ - d__1 = v[i__] * rwt[i__] / vmax; - sum += d__1 * d__1; - } - ret_val = vmax * sqrt(sum / *neq); -L30: - return ret_val; - -/* ------END OF FUNCTION DDWNRM------------------------------------------- */ -} /* ddwnrm_ */ - -/* Subroutine */ int ddasid_(doublereal *x, doublereal *y, doublereal *yprime, - integer *neq, integer *icopt, integer *id, S_fp res, U_fp jacd, - doublereal *pdum, doublereal *h__, doublereal *tscale, doublereal *wt, - integer *jsdum, doublereal *rpar, integer *ipar, doublereal *dumsvr, - doublereal *delta, doublereal *r__, doublereal *yic, doublereal *ypic, - doublereal *dumpwk, doublereal *wm, integer *iwm, doublereal *cj, - doublereal *uround, doublereal *dume, doublereal *dums, doublereal * - dumr, doublereal *epcon, doublereal *ratemx, doublereal *stptol, - integer *jfdum, integer *icnflg, integer *icnstr, integer *iernls) -{ - integer nj, ierj, ires, mxnj; - extern /* Subroutine */ int dmatd_(integer *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *, - doublereal *, doublereal *, doublereal *, integer *, S_fp, - integer *, doublereal *, U_fp, doublereal *, integer *), dnsid_( - doublereal *, doublereal *, doublereal *, integer *, integer *, - integer *, S_fp, doublereal *, doublereal *, integer *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *, doublereal *, integer *, integer *, - integer *); - integer mxnit, iernew; - - -/* ***BEGIN PROLOGUE DDASID */ -/* ***REFER TO DDASPK */ -/* ***DATE WRITTEN 940701 (YYMMDD) */ -/* ***REVISION DATE 950808 (YYMMDD) */ -/* ***REVISION DATE 951110 Removed unreachable block 390. */ -/* ***REVISION DATE 000628 TSCALE argument added. */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - - -/* DDASID solves a nonlinear system of algebraic equations of the */ -/* form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in */ -/* the initial conditions. */ - -/* The method used is a modified Newton scheme. */ - -/* The parameters represent */ - -/* X -- Independent variable. */ -/* Y -- Solution vector. */ -/* YPRIME -- Derivative of solution vector. */ -/* NEQ -- Number of unknowns. */ -/* ICOPT -- Initial condition option chosen (1 or 2). */ -/* ID -- Array of dimension NEQ, which must be initialized */ -/* if ICOPT = 1. See DDASIC. */ -/* RES -- External user-supplied subroutine to evaluate the */ -/* residual. See RES description in DDASPK prologue. */ -/* JACD -- External user-supplied routine to evaluate the */ -/* Jacobian. See JAC description for the case */ -/* INFO(12) = 0 in the DDASPK prologue. */ -/* PDUM -- Dummy argument. */ -/* H -- Scaling factor for this initial condition calc. */ -/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ -/* WT -- Vector of weights for error criterion. */ -/* JSDUM -- Dummy argument. */ -/* RPAR,IPAR -- Real and integer arrays used for communication */ -/* between the calling program and external user */ -/* routines. They are not altered within DASPK. */ -/* DUMSVR -- Dummy argument. */ -/* DELTA -- Work vector for NLS of length NEQ. */ -/* R -- Work vector for NLS of length NEQ. */ -/* YIC,YPIC -- Work vectors for NLS, each of length NEQ. */ -/* DUMPWK -- Dummy argument. */ -/* WM,IWM -- Real and integer arrays storing matrix information */ -/* such as the matrix of partial derivatives, */ -/* permutation vector, and various other information. */ -/* CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). */ -/* UROUND -- Unit roundoff. */ -/* DUME -- Dummy argument. */ -/* DUMS -- Dummy argument. */ -/* DUMR -- Dummy argument. */ -/* EPCON -- Tolerance to test for convergence of the Newton */ -/* iteration. */ -/* RATEMX -- Maximum convergence rate for which Newton iteration */ -/* is considered converging. */ -/* JFDUM -- Dummy argument. */ -/* STPTOL -- Tolerance used in calculating the minimum lambda */ -/* value allowed. */ -/* ICNFLG -- Integer scalar. If nonzero, then constraint */ -/* violations in the proposed new approximate solution */ -/* will be checked for, and the maximum step length */ -/* will be adjusted accordingly. */ -/* ICNSTR -- Integer array of length NEQ containing flags for */ -/* checking constraints. */ -/* IERNLS -- Error flag for nonlinear solver. */ -/* 0 ==> nonlinear solver converged. */ -/* 1,2 ==> recoverable error inside nonlinear solver. */ -/* 1 => retry with current Y, YPRIME */ -/* 2 => retry with original Y, YPRIME */ -/* -1 ==> unrecoverable error in nonlinear solver. */ - -/* All variables with "DUM" in their names are dummy variables */ -/* which are not used in this routine. */ - -/* ----------------------------------------------------------------------- */ - -/* ***ROUTINES CALLED */ -/* RES, DMATD, DNSID */ - -/* ***END PROLOGUE DDASID */ - - - - - -/* Perform initializations. */ - - /* Parameter adjustments */ - --icnstr; - --iwm; - --wm; - --ypic; - --yic; - --r__; - --delta; - --ipar; - --rpar; - --wt; - --id; - --yprime; - --y; - - /* Function Body */ - mxnit = iwm[32]; - mxnj = iwm[33]; - *iernls = 0; - nj = 0; - -/* Call RES to initialize DELTA. */ - - ires = 0; - ++iwm[12]; - (*res)(x, &y[1], &yprime[1], cj, &delta[1], &ires, &rpar[1], &ipar[1]); - if (ires < 0) { - goto L370; - } - -/* Looping point for updating the Jacobian. */ - -L300: - -/* Initialize all error flags to zero. */ - - ierj = 0; - ires = 0; - iernew = 0; - -/* Reevaluate the iteration matrix, J = dG/dY + CJ*dG/dYPRIME, */ -/* where G(X,Y,YPRIME) = 0. */ - - ++nj; - ++iwm[13]; - dmatd_(neq, x, &y[1], &yprime[1], &delta[1], cj, h__, &ierj, &wt[1], &r__[ - 1], &wm[1], &iwm[1], (S_fp)res, &ires, uround, (U_fp)jacd, &rpar[ - 1], &ipar[1]); - if (ires < 0 || ierj != 0) { - goto L370; - } - -/* Call the nonlinear Newton solver for up to MXNIT iterations. */ - - dnsid_(x, &y[1], &yprime[1], neq, icopt, &id[1], (S_fp)res, &wt[1], &rpar[ - 1], &ipar[1], &delta[1], &r__[1], &yic[1], &ypic[1], &wm[1], &iwm[ - 1], cj, tscale, epcon, ratemx, &mxnit, stptol, icnflg, &icnstr[1], - &iernew); - - if (iernew == 1 && nj < mxnj) { - -/* MXNIT iterations were done, the convergence rate is < 1, */ -/* and the number of Jacobian evaluations is less than MXNJ. */ -/* Call RES, reevaluate the Jacobian, and try again. */ - - ++iwm[12]; - (*res)(x, &y[1], &yprime[1], cj, &delta[1], &ires, &rpar[1], &ipar[1]) - ; - if (ires < 0) { - goto L370; - } - goto L300; - } - - if (iernew != 0) { - goto L380; - } - return 0; - - -/* Unsuccessful exits from nonlinear solver. */ -/* Compute IERNLS accordingly. */ - -L370: - *iernls = 2; - if (ires <= -2) { - *iernls = -1; - } - return 0; - -L380: - *iernls = min(iernew,2); - return 0; - -/* ------END OF SUBROUTINE DDASID----------------------------------------- */ -} /* ddasid_ */ - -/* Subroutine */ int dnsid_(doublereal *x, doublereal *y, doublereal *yprime, - integer *neq, integer *icopt, integer *id, S_fp res, doublereal *wt, - doublereal *rpar, integer *ipar, doublereal *delta, doublereal *r__, - doublereal *yic, doublereal *ypic, doublereal *wm, integer *iwm, - doublereal *cj, doublereal *tscale, doublereal *epcon, doublereal * - ratemx, integer *maxit, doublereal *stptol, integer *icnflg, integer * - icnstr, integer *iernew) -{ - integer m; - doublereal rlx, rate, fnrm; - integer iret, ires, lsoff; - extern /* Subroutine */ int dslvd_(integer *, doublereal *, doublereal *, - integer *), dcopy_(integer *, doublereal *, integer *, doublereal - *, integer *), dlinsd_(integer *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - S_fp, integer *, doublereal *, integer *, doublereal *, integer *, - integer *, doublereal *, doublereal *, doublereal *, integer *, - integer *, doublereal *, doublereal *, integer *); - doublereal oldfnm, delnrm; - extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, - doublereal *, integer *); - - -/* ***BEGIN PROLOGUE DNSID */ -/* ***REFER TO DDASPK */ -/* ***DATE WRITTEN 940701 (YYMMDD) */ -/* ***REVISION DATE 950713 (YYMMDD) */ -/* ***REVISION DATE 000628 TSCALE argument added. */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* DNSID solves a nonlinear system of algebraic equations of the */ -/* form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME */ -/* in the initial conditions. */ - -/* The method used is a modified Newton scheme. */ - -/* The parameters represent */ - -/* X -- Independent variable. */ -/* Y -- Solution vector. */ -/* YPRIME -- Derivative of solution vector. */ -/* NEQ -- Number of unknowns. */ -/* ICOPT -- Initial condition option chosen (1 or 2). */ -/* ID -- Array of dimension NEQ, which must be initialized */ -/* if ICOPT = 1. See DDASIC. */ -/* RES -- External user-supplied subroutine to evaluate the */ -/* residual. See RES description in DDASPK prologue. */ -/* WT -- Vector of weights for error criterion. */ -/* RPAR,IPAR -- Real and integer arrays used for communication */ -/* between the calling program and external user */ -/* routines. They are not altered within DASPK. */ -/* DELTA -- Residual vector on entry, and work vector of */ -/* length NEQ for DNSID. */ -/* WM,IWM -- Real and integer arrays storing matrix information */ -/* such as the matrix of partial derivatives, */ -/* permutation vector, and various other information. */ -/* CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). */ -/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ -/* R -- Array of length NEQ used as workspace by the */ -/* linesearch routine DLINSD. */ -/* YIC,YPIC -- Work vectors for DLINSD, each of length NEQ. */ -/* EPCON -- Tolerance to test for convergence of the Newton */ -/* iteration. */ -/* RATEMX -- Maximum convergence rate for which Newton iteration */ -/* is considered converging. */ -/* MAXIT -- Maximum allowed number of Newton iterations. */ -/* STPTOL -- Tolerance used in calculating the minimum lambda */ -/* value allowed. */ -/* ICNFLG -- Integer scalar. If nonzero, then constraint */ -/* violations in the proposed new approximate solution */ -/* will be checked for, and the maximum step length */ -/* will be adjusted accordingly. */ -/* ICNSTR -- Integer array of length NEQ containing flags for */ -/* checking constraints. */ -/* IERNEW -- Error flag for Newton iteration. */ -/* 0 ==> Newton iteration converged. */ -/* 1 ==> failed to converge, but RATE .le. RATEMX. */ -/* 2 ==> failed to converge, RATE .gt. RATEMX. */ -/* 3 ==> other recoverable error (IRES = -1, or */ -/* linesearch failed). */ -/* -1 ==> unrecoverable error (IRES = -2). */ - -/* ----------------------------------------------------------------------- */ - -/* ***ROUTINES CALLED */ -/* DSLVD, DDWNRM, DLINSD, DCOPY */ - -/* ***END PROLOGUE DNSID */ - - - - - -/* Initializations. M is the Newton iteration counter. */ - - /* Parameter adjustments */ - --icnstr; - --iwm; - --wm; - --ypic; - --yic; - --r__; - --delta; - --ipar; - --rpar; - --wt; - --id; - --yprime; - --y; - - /* Function Body */ - lsoff = iwm[35]; - m = 0; - rate = 1.; - rlx = .4; - -/* Compute a new step vector DELTA by back-substitution. */ - - dslvd_(neq, &delta[1], &wm[1], &iwm[1]); - -/* Get norm of DELTA. Return now if norm(DELTA) .le. EPCON. */ - - delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); - fnrm = delnrm; - if (*tscale > 0.) { - fnrm = fnrm * *tscale * abs(*cj); - } - if (fnrm <= *epcon) { - return 0; - } - -/* Newton iteration loop. */ - -L300: - ++iwm[19]; - -/* Call linesearch routine for global strategy and set RATE */ - - oldfnm = fnrm; - - dlinsd_(neq, &y[1], x, &yprime[1], cj, tscale, &delta[1], &delnrm, &wt[1], - &lsoff, stptol, &iret, (S_fp)res, &ires, &wm[1], &iwm[1], &fnrm, - icopt, &id[1], &r__[1], &yic[1], &ypic[1], icnflg, &icnstr[1], & - rlx, &rpar[1], &ipar[1]); - - rate = fnrm / oldfnm; - -/* Check for error condition from linesearch. */ - if (iret != 0) { - goto L390; - } - -/* Test for convergence of the iteration, and return or loop. */ - - if (fnrm <= *epcon) { - return 0; - } - -/* The iteration has not yet converged. Update M. */ -/* Test whether the maximum number of iterations have been tried. */ - - ++m; - if (m >= *maxit) { - goto L380; - } - -/* Copy the residual to DELTA and its norm to DELNRM, and loop for */ -/* another iteration. */ - - dcopy_(neq, &r__[1], &c__1, &delta[1], &c__1); - delnrm = fnrm; - goto L300; - -/* The maximum number of iterations was done. Set IERNEW and return. */ - -L380: - if (rate <= *ratemx) { - *iernew = 1; - } else { - *iernew = 2; - } - return 0; - -L390: - if (ires <= -2) { - *iernew = -1; - } else { - *iernew = 3; - } - return 0; - - -/* ------END OF SUBROUTINE DNSID------------------------------------------ */ -} /* dnsid_ */ - -/* Subroutine */ int dlinsd_(integer *neq, doublereal *y, doublereal *t, - doublereal *yprime, doublereal *cj, doublereal *tscale, doublereal *p, - doublereal *pnrm, doublereal *wt, integer *lsoff, doublereal *stptol, - integer *iret, S_fp res, integer *ires, doublereal *wm, integer *iwm, - doublereal *fnrm, integer *icopt, integer *id, doublereal *r__, - doublereal *ynew, doublereal *ypnew, integer *icnflg, integer *icnstr, - doublereal *rlx, doublereal *rpar, integer *ipar) -{ - /* Initialized data */ - - static doublereal alpha = 1e-4; - static doublereal one = 1.; - static doublereal two = 2.; - - /* System generated locals */ - integer i__1; - - /* Builtin functions */ - /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); - - /* Local variables */ - integer i__; - doublereal rl; - char msg[80]; - doublereal tau; - integer ivar; - doublereal slpi, f1nrm, ratio; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); - doublereal rlmin, fnrmp; - integer kprin; - doublereal ratio1, f1nrmp; - extern /* Subroutine */ int dfnrmd_(integer *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, S_fp, integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *), dcnstr_(integer *, - doublereal *, doublereal *, integer *, doublereal *, doublereal *, - integer *, integer *), xerrwd_(char *, integer *, integer *, - integer *, integer *, integer *, integer *, integer *, doublereal - *, doublereal *, ftnlen), dyypnw_(integer *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *, - integer *, doublereal *, doublereal *); - - -/* ***BEGIN PROLOGUE DLINSD */ -/* ***REFER TO DNSID */ -/* ***DATE WRITTEN 941025 (YYMMDD) */ -/* ***REVISION DATE 941215 (YYMMDD) */ -/* ***REVISION DATE 960129 Moved line RL = ONE to top block. */ -/* ***REVISION DATE 000628 TSCALE argument added. */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* DLINSD uses a linesearch algorithm to calculate a new (Y,YPRIME) */ -/* pair (YNEW,YPNEW) such that */ - -/* f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) , */ - -/* where 0 < RL <= 1. Here, f(y,y') is defined as */ - -/* f(y,y') = (1/2)*norm( (J-inverse)*G(t,y,y') )**2 , */ - -/* where norm() is the weighted RMS vector norm, G is the DAE */ -/* system residual function, and J is the system iteration matrix */ -/* (Jacobian). */ - -/* In addition to the parameters defined elsewhere, we have */ - -/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ -/* P -- Approximate Newton step used in backtracking. */ -/* PNRM -- Weighted RMS norm of P. */ -/* LSOFF -- Flag showing whether the linesearch algorithm is */ -/* to be invoked. 0 means do the linesearch, and */ -/* 1 means turn off linesearch. */ -/* STPTOL -- Tolerance used in calculating the minimum lambda */ -/* value allowed. */ -/* ICNFLG -- Integer scalar. If nonzero, then constraint violations */ -/* in the proposed new approximate solution will be */ -/* checked for, and the maximum step length will be */ -/* adjusted accordingly. */ -/* ICNSTR -- Integer array of length NEQ containing flags for */ -/* checking constraints. */ -/* RLX -- Real scalar restricting update size in DCNSTR. */ -/* YNEW -- Array of length NEQ used to hold the new Y in */ -/* performing the linesearch. */ -/* YPNEW -- Array of length NEQ used to hold the new YPRIME in */ -/* performing the linesearch. */ -/* Y -- Array of length NEQ containing the new Y (i.e.,=YNEW). */ -/* YPRIME -- Array of length NEQ containing the new YPRIME */ -/* (i.e.,=YPNEW). */ -/* FNRM -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the */ -/* current (Y,YPRIME) on input and output. */ -/* R -- Work array of length NEQ, containing the scaled */ -/* residual (J-inverse)*G(t,y,y') on return. */ -/* IRET -- Return flag. */ -/* IRET=0 means that a satisfactory (Y,YPRIME) was found. */ -/* IRET=1 means that the routine failed to find a new */ -/* (Y,YPRIME) that was sufficiently distinct from */ -/* the current (Y,YPRIME) pair. */ -/* IRET=2 means IRES .ne. 0 from RES. */ -/* ----------------------------------------------------------------------- */ - -/* ***ROUTINES CALLED */ -/* DFNRMD, DYYPNW, DCNSTR, DCOPY, XERRWD */ - -/* ***END PROLOGUE DLINSD */ - - - - /* Parameter adjustments */ - --ipar; - --rpar; - --icnstr; - --ypnew; - --ynew; - --r__; - --id; - --iwm; - --wm; - --wt; - --p; - --yprime; - --y; - - /* Function Body */ - - kprin = iwm[31]; - - f1nrm = *fnrm * *fnrm / two; - ratio = one; - if (kprin >= 2) { - s_copy(msg, "------ IN ROUTINE DLINSD-- PNRM = (R1)", (ftnlen)80, ( - ftnlen)38); - xerrwd_(msg, &c__38, &c__901, &c__0, &c__0, &c__0, &c__0, &c__1, pnrm, - &c_b37, (ftnlen)80); - } - tau = *pnrm; - rl = one; -/* ----------------------------------------------------------------------- */ -/* Check for violations of the constraints, if any are imposed. */ -/* If any violations are found, the step vector P is rescaled, and the */ -/* constraint check is repeated, until no violations are found. */ -/* ----------------------------------------------------------------------- */ - if (*icnflg != 0) { -L10: - dyypnw_(neq, &y[1], &yprime[1], cj, &rl, &p[1], icopt, &id[1], &ynew[ - 1], &ypnew[1]); - dcnstr_(neq, &y[1], &ynew[1], &icnstr[1], &tau, rlx, iret, &ivar); - if (*iret == 1) { - ratio1 = tau / *pnrm; - ratio *= ratio1; - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L20: */ - p[i__] *= ratio1; - } - *pnrm = tau; - if (kprin >= 2) { - s_copy(msg, "------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (" - "I1)", (ftnlen)80, (ftnlen)50); - xerrwd_(msg, &c__50, &c__902, &c__0, &c__1, &ivar, &c__0, & - c__1, pnrm, &c_b37, (ftnlen)80); - } - if (*pnrm <= *stptol) { - *iret = 1; - return 0; - } - goto L10; - } - } - - slpi = -two * f1nrm * ratio; - rlmin = *stptol / *pnrm; - if (*lsoff == 0 && kprin >= 2) { - s_copy(msg, "------ MIN. LAMBDA = (R1)", (ftnlen)80, (ftnlen)25); - xerrwd_(msg, &c__25, &c__903, &c__0, &c__0, &c__0, &c__0, &c__1, & - rlmin, &c_b37, (ftnlen)80); - } -/* ----------------------------------------------------------------------- */ -/* Begin iteration to find RL value satisfying alpha-condition. */ -/* If RL becomes less than RLMIN, then terminate with IRET = 1. */ -/* ----------------------------------------------------------------------- */ -L100: - dyypnw_(neq, &y[1], &yprime[1], cj, &rl, &p[1], icopt, &id[1], &ynew[1], & - ypnew[1]); - dfnrmd_(neq, &ynew[1], t, &ypnew[1], &r__[1], cj, tscale, &wt[1], (S_fp) - res, ires, &fnrmp, &wm[1], &iwm[1], &rpar[1], &ipar[1]); - ++iwm[12]; - if (*ires != 0) { - *iret = 2; - return 0; - } - if (*lsoff == 1) { - goto L150; - } - - f1nrmp = fnrmp * fnrmp / two; - if (kprin >= 2) { - s_copy(msg, "------ LAMBDA = (R1)", (ftnlen)80, (ftnlen)20); - xerrwd_(msg, &c__20, &c__904, &c__0, &c__0, &c__0, &c__0, &c__1, &rl, - &c_b37, (ftnlen)80); - s_copy(msg, "------ NORM(F1) = (R1), NORM(F1NEW) = (R2)", (ftnlen)80, - (ftnlen)43); - xerrwd_(msg, &c__43, &c__905, &c__0, &c__0, &c__0, &c__0, &c__2, & - f1nrm, &f1nrmp, (ftnlen)80); - } - if (f1nrmp > f1nrm + alpha * slpi * rl) { - goto L200; - } -/* ----------------------------------------------------------------------- */ -/* Alpha-condition is satisfied, or linesearch is turned off. */ -/* Copy YNEW,YPNEW to Y,YPRIME and return. */ -/* ----------------------------------------------------------------------- */ -L150: - *iret = 0; - dcopy_(neq, &ynew[1], &c__1, &y[1], &c__1); - dcopy_(neq, &ypnew[1], &c__1, &yprime[1], &c__1); - *fnrm = fnrmp; - if (kprin >= 1) { - s_copy(msg, "------ LEAVING ROUTINE DLINSD, FNRM = (R1)", (ftnlen)80, - (ftnlen)42); - xerrwd_(msg, &c__42, &c__906, &c__0, &c__0, &c__0, &c__0, &c__1, fnrm, - &c_b37, (ftnlen)80); - } - return 0; -/* ----------------------------------------------------------------------- */ -/* Alpha-condition not satisfied. Perform backtrack to compute new RL */ -/* value. If no satisfactory YNEW,YPNEW can be found sufficiently */ -/* distinct from Y,YPRIME, then return IRET = 1. */ -/* ----------------------------------------------------------------------- */ -L200: - if (rl < rlmin) { - *iret = 1; - return 0; - } - - rl /= two; - goto L100; - -/* ----------------------- END OF SUBROUTINE DLINSD ---------------------- */ -} /* dlinsd_ */ - -/* Subroutine */ int dfnrmd_(integer *neq, doublereal *y, doublereal *t, - doublereal *yprime, doublereal *r__, doublereal *cj, doublereal * - tscale, doublereal *wt, S_fp res, integer *ires, doublereal *fnorm, - doublereal *wm, integer *iwm, doublereal *rpar, integer *ipar) -{ - extern /* Subroutine */ int dslvd_(integer *, doublereal *, doublereal *, - integer *); - extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, - doublereal *, integer *); - - -/* ***BEGIN PROLOGUE DFNRMD */ -/* ***REFER TO DLINSD */ -/* ***DATE WRITTEN 941025 (YYMMDD) */ -/* ***REVISION DATE 000628 TSCALE argument added. */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* DFNRMD calculates the scaled preconditioned norm of the nonlinear */ -/* function used in the nonlinear iteration for obtaining consistent */ -/* initial conditions. Specifically, DFNRMD calculates the weighted */ -/* root-mean-square norm of the vector (J-inverse)*G(T,Y,YPRIME), */ -/* where J is the Jacobian matrix. */ - -/* In addition to the parameters described in the calling program */ -/* DLINSD, the parameters represent */ - -/* R -- Array of length NEQ that contains */ -/* (J-inverse)*G(T,Y,YPRIME) on return. */ -/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ -/* FNORM -- Scalar containing the weighted norm of R on return. */ -/* ----------------------------------------------------------------------- */ - -/* ***ROUTINES CALLED */ -/* RES, DSLVD, DDWNRM */ - -/* ***END PROLOGUE DFNRMD */ - - -/* ----------------------------------------------------------------------- */ -/* Call RES routine. */ -/* ----------------------------------------------------------------------- */ - /* Parameter adjustments */ - --ipar; - --rpar; - --iwm; - --wm; - --wt; - --r__; - --yprime; - --y; - - /* Function Body */ - *ires = 0; - (*res)(t, &y[1], &yprime[1], cj, &r__[1], ires, &rpar[1], &ipar[1]); - if (*ires < 0) { - return 0; - } -/* ----------------------------------------------------------------------- */ -/* Apply inverse of Jacobian to vector R. */ -/* ----------------------------------------------------------------------- */ - dslvd_(neq, &r__[1], &wm[1], &iwm[1]); -/* ----------------------------------------------------------------------- */ -/* Calculate norm of R. */ -/* ----------------------------------------------------------------------- */ - *fnorm = ddwnrm_(neq, &r__[1], &wt[1], &rpar[1], &ipar[1]); - if (*tscale > 0.) { - *fnorm = *fnorm * *tscale * abs(*cj); - } - - return 0; -/* ----------------------- END OF SUBROUTINE DFNRMD ---------------------- */ -} /* dfnrmd_ */ - -/* Subroutine */ int dnedd_(doublereal *x, doublereal *y, doublereal *yprime, - integer *neq, S_fp res, U_fp jacd, doublereal *pdum, doublereal *h__, - doublereal *wt, integer *jstart, integer *idid, doublereal *rpar, - integer *ipar, doublereal *phi, doublereal *gamma, doublereal *dumsvr, - doublereal *delta, doublereal *e, doublereal *wm, integer *iwm, - doublereal *cj, doublereal *cjold, doublereal *cjlast, doublereal *s, - doublereal *uround, doublereal *dume, doublereal *dums, doublereal * - dumr, doublereal *epcon, integer *jcalc, integer *jfdum, integer *kp1, - integer *nonneg, integer *ntype, integer *iernls) -{ - /* Initialized data */ - - static integer muldel = 1; - static integer maxit = 4; - static doublereal xrate = .25; - - /* System generated locals */ - integer phi_dim1, phi_offset, i__1, i__2; - doublereal d__1; - - /* Local variables */ - integer i__, j, ierj; - extern /* Subroutine */ int dnsd_(doublereal *, doublereal *, doublereal * - , integer *, S_fp, doublereal *, doublereal *, doublereal *, - integer *, doublereal *, doublereal *, doublereal *, doublereal *, - integer *, doublereal *, doublereal *, doublereal *, doublereal * - , doublereal *, doublereal *, doublereal *, doublereal *, integer - *, integer *, integer *, integer *, integer *); - integer idum, ires; - doublereal temp1, temp2; - extern /* Subroutine */ int dmatd_(integer *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *, - doublereal *, doublereal *, doublereal *, integer *, S_fp, - integer *, doublereal *, U_fp, doublereal *, integer *); - doublereal pnorm, delnrm; - integer iernew; - extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, - doublereal *, integer *); - doublereal tolnew; - integer iertyp; - - -/* ***BEGIN PROLOGUE DNEDD */ -/* ***REFER TO DDASPK */ -/* ***DATE WRITTEN 891219 (YYMMDD) */ -/* ***REVISION DATE 900926 (YYMMDD) */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* DNEDD solves a nonlinear system of */ -/* algebraic equations of the form */ -/* G(X,Y,YPRIME) = 0 for the unknown Y. */ - -/* The method used is a modified Newton scheme. */ - -/* The parameters represent */ - -/* X -- Independent variable. */ -/* Y -- Solution vector. */ -/* YPRIME -- Derivative of solution vector. */ -/* NEQ -- Number of unknowns. */ -/* RES -- External user-supplied subroutine */ -/* to evaluate the residual. See RES description */ -/* in DDASPK prologue. */ -/* JACD -- External user-supplied routine to evaluate the */ -/* Jacobian. See JAC description for the case */ -/* INFO(12) = 0 in the DDASPK prologue. */ -/* PDUM -- Dummy argument. */ -/* H -- Appropriate step size for next step. */ -/* WT -- Vector of weights for error criterion. */ -/* JSTART -- Indicates first call to this routine. */ -/* If JSTART = 0, then this is the first call, */ -/* otherwise it is not. */ -/* IDID -- Completion flag, output by DNEDD. */ -/* See IDID description in DDASPK prologue. */ -/* RPAR,IPAR -- Real and integer arrays used for communication */ -/* between the calling program and external user */ -/* routines. They are not altered within DASPK. */ -/* PHI -- Array of divided differences used by */ -/* DNEDD. The length is NEQ*(K+1),where */ -/* K is the maximum order. */ -/* GAMMA -- Array used to predict Y and YPRIME. The length */ -/* is MAXORD+1 where MAXORD is the maximum order. */ -/* DUMSVR -- Dummy argument. */ -/* DELTA -- Work vector for NLS of length NEQ. */ -/* E -- Error accumulation vector for NLS of length NEQ. */ -/* WM,IWM -- Real and integer arrays storing */ -/* matrix information such as the matrix */ -/* of partial derivatives, permutation */ -/* vector, and various other information. */ -/* CJ -- Parameter always proportional to 1/H. */ -/* CJOLD -- Saves the value of CJ as of the last call to DMATD. */ -/* Accounts for changes in CJ needed to */ -/* decide whether to call DMATD. */ -/* CJLAST -- Previous value of CJ. */ -/* S -- A scalar determined by the approximate rate */ -/* of convergence of the Newton iteration and used */ -/* in the convergence test for the Newton iteration. */ - -/* If RATE is defined to be an estimate of the */ -/* rate of convergence of the Newton iteration, */ -/* then S = RATE/(1.D0-RATE). */ - -/* The closer RATE is to 0., the faster the Newton */ -/* iteration is converging; the closer RATE is to 1., */ -/* the slower the Newton iteration is converging. */ - -/* On the first Newton iteration with an up-dated */ -/* preconditioner S = 100.D0, Thus the initial */ -/* RATE of convergence is approximately 1. */ - -/* S is preserved from call to call so that the rate */ -/* estimate from a previous step can be applied to */ -/* the current step. */ -/* UROUND -- Unit roundoff. */ -/* DUME -- Dummy argument. */ -/* DUMS -- Dummy argument. */ -/* DUMR -- Dummy argument. */ -/* EPCON -- Tolerance to test for convergence of the Newton */ -/* iteration. */ -/* JCALC -- Flag used to determine when to update */ -/* the Jacobian matrix. In general: */ - -/* JCALC = -1 ==> Call the DMATD routine to update */ -/* the Jacobian matrix. */ -/* JCALC = 0 ==> Jacobian matrix is up-to-date. */ -/* JCALC = 1 ==> Jacobian matrix is out-dated, */ -/* but DMATD will not be called unless */ -/* JCALC is set to -1. */ -/* JFDUM -- Dummy argument. */ -/* KP1 -- The current order(K) + 1; updated across calls. */ -/* NONNEG -- Flag to determine nonnegativity constraints. */ -/* NTYPE -- Identification code for the NLS routine. */ -/* 0 ==> modified Newton; direct solver. */ -/* IERNLS -- Error flag for nonlinear solver. */ -/* 0 ==> nonlinear solver converged. */ -/* 1 ==> recoverable error inside nonlinear solver. */ -/* -1 ==> unrecoverable error inside nonlinear solver. */ - -/* All variables with "DUM" in their names are dummy variables */ -/* which are not used in this routine. */ - -/* Following is a list and description of local variables which */ -/* may not have an obvious usage. They are listed in roughly the */ -/* order they occur in this subroutine. */ - -/* The following group of variables are passed as arguments to */ -/* the Newton iteration solver. They are explained in greater detail */ -/* in DNSD: */ -/* TOLNEW, MULDEL, MAXIT, IERNEW */ - -/* IERTYP -- Flag which tells whether this subroutine is correct. */ -/* 0 ==> correct subroutine. */ -/* 1 ==> incorrect subroutine. */ - -/* ----------------------------------------------------------------------- */ -/* ***ROUTINES CALLED */ -/* DDWNRM, RES, DMATD, DNSD */ - -/* ***END PROLOGUE DNEDD */ - - - - - /* Parameter adjustments */ - --y; - --yprime; - phi_dim1 = *neq; - phi_offset = 1 + phi_dim1; - phi -= phi_offset; - --wt; - --rpar; - --ipar; - --gamma; - --delta; - --e; - --wm; - --iwm; - - /* Function Body */ - -/* Verify that this is the correct subroutine. */ - - iertyp = 0; - if (*ntype != 0) { - iertyp = 1; - goto L380; - } - -/* If this is the first step, perform initializations. */ - - if (*jstart == 0) { - *cjold = *cj; - *jcalc = -1; - } - -/* Perform all other initializations. */ - - *iernls = 0; - -/* Decide whether new Jacobian is needed. */ - - temp1 = (1. - xrate) / (xrate + 1.); - temp2 = 1. / temp1; - if (*cj / *cjold < temp1 || *cj / *cjold > temp2) { - *jcalc = -1; - } - if (*cj != *cjlast) { - *s = 100.; - } - -/* ----------------------------------------------------------------------- */ -/* Entry point for updating the Jacobian with current */ -/* stepsize. */ -/* ----------------------------------------------------------------------- */ -L300: - -/* Initialize all error flags to zero. */ - - ierj = 0; - ires = 0; - iernew = 0; - -/* Predict the solution and derivative and compute the tolerance */ -/* for the Newton iteration. */ - - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = phi[i__ + phi_dim1]; -/* L310: */ - yprime[i__] = 0.; - } - i__1 = *kp1; - for (j = 2; j <= i__1; ++j) { - i__2 = *neq; - for (i__ = 1; i__ <= i__2; ++i__) { - y[i__] += phi[i__ + j * phi_dim1]; -/* L320: */ - yprime[i__] += gamma[j] * phi[i__ + j * phi_dim1]; - } -/* L330: */ - } - pnorm = ddwnrm_(neq, &y[1], &wt[1], &rpar[1], &ipar[1]); - tolnew = *uround * 100. * pnorm; - -/* Call RES to initialize DELTA. */ - - ++iwm[12]; - (*res)(x, &y[1], &yprime[1], cj, &delta[1], &ires, &rpar[1], &ipar[1]); - if (ires < 0) { - goto L380; - } - -/* If indicated, reevaluate the iteration matrix */ -/* J = dG/dY + CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). */ -/* Set JCALC to 0 as an indicator that this has been done. */ - - if (*jcalc == -1) { - ++iwm[13]; - *jcalc = 0; - dmatd_(neq, x, &y[1], &yprime[1], &delta[1], cj, h__, &ierj, &wt[1], & - e[1], &wm[1], &iwm[1], (S_fp)res, &ires, uround, (U_fp)jacd, & - rpar[1], &ipar[1]); - *cjold = *cj; - *s = 100.; - if (ires < 0) { - goto L380; - } - if (ierj != 0) { - goto L380; - } - } - -/* Call the nonlinear Newton solver. */ - - temp1 = 2. / (*cj / *cjold + 1.); - dnsd_(x, &y[1], &yprime[1], neq, (S_fp)res, pdum, &wt[1], &rpar[1], &ipar[ - 1], dumsvr, &delta[1], &e[1], &wm[1], &iwm[1], cj, dums, dumr, - dume, epcon, s, &temp1, &tolnew, &muldel, &maxit, &ires, &idum, & - iernew); - - if (iernew > 0 && *jcalc != 0) { - -/* The Newton iteration had a recoverable failure with an old */ -/* iteration matrix. Retry the step with a new iteration matrix. */ - - *jcalc = -1; - goto L300; - } - - if (iernew != 0) { - goto L380; - } - -/* The Newton iteration has converged. If nonnegativity of */ -/* solution is required, set the solution nonnegative, if the */ -/* perturbation to do it is small enough. If the change is too */ -/* large, then consider the corrector iteration to have failed. */ - -/* L375: */ - if (*nonneg == 0) { - goto L390; - } - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L377: */ -/* Computing MIN */ - d__1 = y[i__]; - delta[i__] = min(d__1,0.); - } - delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); - if (delnrm > *epcon) { - goto L380; - } - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L378: */ - e[i__] -= delta[i__]; - } - goto L390; - - -/* Exits from nonlinear solver. */ -/* No convergence with current iteration */ -/* matrix, or singular iteration matrix. */ -/* Compute IERNLS and IDID accordingly. */ - -L380: - if (ires <= -2 || iertyp != 0) { - *iernls = -1; - if (ires <= -2) { - *idid = -11; - } - if (iertyp != 0) { - *idid = -15; - } - } else { - *iernls = 1; - if (ires < 0) { - *idid = -10; - } - if (ierj != 0) { - *idid = -8; - } - } - -L390: - *jcalc = 1; - return 0; - -/* ------END OF SUBROUTINE DNEDD------------------------------------------ */ -} /* dnedd_ */ - -/* Subroutine */ int dnsd_(doublereal *x, doublereal *y, doublereal *yprime, - integer *neq, S_fp res, doublereal *pdum, doublereal *wt, doublereal * - rpar, integer *ipar, doublereal *dumsvr, doublereal *delta, - doublereal *e, doublereal *wm, integer *iwm, doublereal *cj, - doublereal *dums, doublereal *dumr, doublereal *dume, doublereal * - epcon, doublereal *s, doublereal *confac, doublereal *tolnew, integer - *muldel, integer *maxit, integer *ires, integer *idum, integer * - iernew) -{ - /* System generated locals */ - integer i__1; - doublereal d__1, d__2; - - /* Builtin functions */ - double pow_dd(doublereal *, doublereal *); - - /* Local variables */ - integer i__, m; - doublereal rate; - extern /* Subroutine */ int dslvd_(integer *, doublereal *, doublereal *, - integer *); - doublereal delnrm; - extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, - doublereal *, integer *); - doublereal oldnrm; - - -/* ***BEGIN PROLOGUE DNSD */ -/* ***REFER TO DDASPK */ -/* ***DATE WRITTEN 891219 (YYMMDD) */ -/* ***REVISION DATE 900926 (YYMMDD) */ -/* ***REVISION DATE 950126 (YYMMDD) */ -/* ***REVISION DATE 000711 (YYMMDD) */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* DNSD solves a nonlinear system of */ -/* algebraic equations of the form */ -/* G(X,Y,YPRIME) = 0 for the unknown Y. */ - -/* The method used is a modified Newton scheme. */ - -/* The parameters represent */ - -/* X -- Independent variable. */ -/* Y -- Solution vector. */ -/* YPRIME -- Derivative of solution vector. */ -/* NEQ -- Number of unknowns. */ -/* RES -- External user-supplied subroutine */ -/* to evaluate the residual. See RES description */ -/* in DDASPK prologue. */ -/* PDUM -- Dummy argument. */ -/* WT -- Vector of weights for error criterion. */ -/* RPAR,IPAR -- Real and integer arrays used for communication */ -/* between the calling program and external user */ -/* routines. They are not altered within DASPK. */ -/* DUMSVR -- Dummy argument. */ -/* DELTA -- Work vector for DNSD of length NEQ. */ -/* E -- Error accumulation vector for DNSD of length NEQ. */ -/* WM,IWM -- Real and integer arrays storing */ -/* matrix information such as the matrix */ -/* of partial derivatives, permutation */ -/* vector, and various other information. */ -/* CJ -- Parameter always proportional to 1/H (step size). */ -/* DUMS -- Dummy argument. */ -/* DUMR -- Dummy argument. */ -/* DUME -- Dummy argument. */ -/* EPCON -- Tolerance to test for convergence of the Newton */ -/* iteration. */ -/* S -- Used for error convergence tests. */ -/* In the Newton iteration: S = RATE/(1 - RATE), */ -/* where RATE is the estimated rate of convergence */ -/* of the Newton iteration. */ -/* The calling routine passes the initial value */ -/* of S to the Newton iteration. */ -/* CONFAC -- A residual scale factor to improve convergence. */ -/* TOLNEW -- Tolerance on the norm of Newton correction in */ -/* alternative Newton convergence test. */ -/* MULDEL -- A flag indicating whether or not to multiply */ -/* DELTA by CONFAC. */ -/* 0 ==> do not scale DELTA by CONFAC. */ -/* 1 ==> scale DELTA by CONFAC. */ -/* MAXIT -- Maximum allowed number of Newton iterations. */ -/* IRES -- Error flag returned from RES. See RES description */ -/* in DDASPK prologue. If IRES = -1, then IERNEW */ -/* will be set to 1. */ -/* If IRES < -1, then IERNEW will be set to -1. */ -/* IDUM -- Dummy argument. */ -/* IERNEW -- Error flag for Newton iteration. */ -/* 0 ==> Newton iteration converged. */ -/* 1 ==> recoverable error inside Newton iteration. */ -/* -1 ==> unrecoverable error inside Newton iteration. */ - -/* All arguments with "DUM" in their names are dummy arguments */ -/* which are not used in this routine. */ -/* ----------------------------------------------------------------------- */ - -/* ***ROUTINES CALLED */ -/* DSLVD, DDWNRM, RES */ - -/* ***END PROLOGUE DNSD */ - - - - -/* Initialize Newton counter M and accumulation vector E. */ - - /* Parameter adjustments */ - --iwm; - --wm; - --e; - --delta; - --ipar; - --rpar; - --wt; - --yprime; - --y; - - /* Function Body */ - m = 0; - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L100: */ - e[i__] = 0.; - } - -/* Corrector loop. */ - -L300: - ++iwm[19]; - -/* If necessary, multiply residual by convergence factor. */ - - if (*muldel == 1) { - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L320: */ - delta[i__] *= *confac; - } - } - -/* Compute a new iterate (back-substitution). */ -/* Store the correction in DELTA. */ - - dslvd_(neq, &delta[1], &wm[1], &iwm[1]); - -/* Update Y, E, and YPRIME. */ - - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] -= delta[i__]; - e[i__] -= delta[i__]; -/* L340: */ - yprime[i__] -= *cj * delta[i__]; - } - -/* Test for convergence of the iteration. */ - - delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); - if (m == 0) { - oldnrm = delnrm; - if (delnrm <= *tolnew) { - goto L370; - } - } else { - d__1 = delnrm / oldnrm; - d__2 = 1. / m; - rate = pow_dd(&d__1, &d__2); - if (rate > .9) { - goto L380; - } - *s = rate / (1. - rate); - } - if (*s * delnrm <= *epcon) { - goto L370; - } - -/* The corrector has not yet converged. */ -/* Update M and test whether the */ -/* maximum number of iterations have */ -/* been tried. */ - - ++m; - if (m >= *maxit) { - goto L380; - } - -/* Evaluate the residual, */ -/* and go back to do another iteration. */ - - ++iwm[12]; - (*res)(x, &y[1], &yprime[1], cj, &delta[1], ires, &rpar[1], &ipar[1]); - if (*ires < 0) { - goto L380; - } - goto L300; - -/* The iteration has converged. */ - -L370: - return 0; - -/* The iteration has not converged. Set IERNEW appropriately. */ - -L380: - if (*ires <= -2) { - *iernew = -1; - } else { - *iernew = 1; - } - return 0; - - -/* ------END OF SUBROUTINE DNSD------------------------------------------- */ -} /* dnsd_ */ - -/* Subroutine */ int dmatd_(integer *neq, doublereal *x, doublereal *y, - doublereal *yprime, doublereal *delta, doublereal *cj, doublereal * - h__, integer *ier, doublereal *ewt, doublereal *e, doublereal *wm, - integer *iwm, S_fp res, integer *ires, doublereal *uround, S_fp jacd, - doublereal *rpar, integer *ipar) -{ - /* System generated locals */ - integer i__1, i__2, i__3, i__4, i__5; - doublereal d__1, d__2, d__3, d__4, d__5; - - /* Builtin functions */ - double sqrt(doublereal), d_sign(doublereal *, doublereal *); - - /* Local variables */ - integer i__, j, k, l, n, i1, i2, ii, mba; - doublereal del; - integer meb1, nrow; - doublereal squr; - extern /* Subroutine */ int dgbfa_(doublereal *, integer *, integer *, - integer *, integer *, integer *, integer *), dgefa_(doublereal *, - integer *, integer *, integer *, integer *); - integer mband, lenpd, isave, msave; - doublereal ysave; - integer lipvt, mtype, meband; - doublereal delinv; - integer ipsave; - doublereal ypsave; - - -/* ***BEGIN PROLOGUE DMATD */ -/* ***REFER TO DDASPK */ -/* ***DATE WRITTEN 890101 (YYMMDD) */ -/* ***REVISION DATE 900926 (YYMMDD) */ -/* ***REVISION DATE 940701 (YYMMDD) (new LIPVT) */ - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* This routine computes the iteration matrix */ -/* J = dG/dY+CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). */ -/* Here J is computed by: */ -/* the user-supplied routine JACD if IWM(MTYPE) is 1 or 4, or */ -/* by numerical difference quotients if IWM(MTYPE) is 2 or 5. */ - -/* The parameters have the following meanings. */ -/* X = Independent variable. */ -/* Y = Array containing predicted values. */ -/* YPRIME = Array containing predicted derivatives. */ -/* DELTA = Residual evaluated at (X,Y,YPRIME). */ -/* (Used only if IWM(MTYPE)=2 or 5). */ -/* CJ = Scalar parameter defining iteration matrix. */ -/* H = Current stepsize in integration. */ -/* IER = Variable which is .NE. 0 if iteration matrix */ -/* is singular, and 0 otherwise. */ -/* EWT = Vector of error weights for computing norms. */ -/* E = Work space (temporary) of length NEQ. */ -/* WM = Real work space for matrices. On output */ -/* it contains the LU decomposition */ -/* of the iteration matrix. */ -/* IWM = Integer work space containing */ -/* matrix information. */ -/* RES = External user-supplied subroutine */ -/* to evaluate the residual. See RES description */ -/* in DDASPK prologue. */ -/* IRES = Flag which is equal to zero if no illegal values */ -/* in RES, and less than zero otherwise. (If IRES */ -/* is less than zero, the matrix was not completed). */ -/* In this case (if IRES .LT. 0), then IER = 0. */ -/* UROUND = The unit roundoff error of the machine being used. */ -/* JACD = Name of the external user-supplied routine */ -/* to evaluate the iteration matrix. (This routine */ -/* is only used if IWM(MTYPE) is 1 or 4) */ -/* See JAC description for the case INFO(12) = 0 */ -/* in DDASPK prologue. */ -/* RPAR,IPAR= Real and integer parameter arrays that */ -/* are used for communication between the */ -/* calling program and external user routines. */ -/* They are not altered by DMATD. */ -/* ----------------------------------------------------------------------- */ -/* ***ROUTINES CALLED */ -/* JACD, RES, DGEFA, DGBFA */ - -/* ***END PROLOGUE DMATD */ - - - - - /* Parameter adjustments */ - --ipar; - --rpar; - --iwm; - --wm; - --e; - --ewt; - --delta; - --yprime; - --y; - - /* Function Body */ - lipvt = iwm[30]; - *ier = 0; - mtype = iwm[4]; - switch (mtype) { - case 1: goto L100; - case 2: goto L200; - case 3: goto L300; - case 4: goto L400; - case 5: goto L500; - } - - -/* Dense user-supplied matrix. */ - -L100: - lenpd = iwm[22]; - i__1 = lenpd; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L110: */ - wm[i__] = 0.; - } - (*jacd)(x, &y[1], &yprime[1], &wm[1], cj, &rpar[1], &ipar[1]); - goto L230; - - -/* Dense finite-difference-generated matrix. */ - -L200: - *ires = 0; - nrow = 0; - squr = sqrt(*uround); - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* Computing MAX */ - d__4 = (d__1 = y[i__], abs(d__1)), d__5 = (d__2 = *h__ * yprime[i__], - abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = 1. / ewt[ - i__], abs(d__3)); - del = squr * max(d__4,d__5); - d__1 = *h__ * yprime[i__]; - del = d_sign(&del, &d__1); - del = y[i__] + del - y[i__]; - ysave = y[i__]; - ypsave = yprime[i__]; - y[i__] += del; - yprime[i__] += *cj * del; - ++iwm[12]; - (*res)(x, &y[1], &yprime[1], cj, &e[1], ires, &rpar[1], &ipar[1]); - if (*ires < 0) { - return 0; - } - delinv = 1. / del; - i__2 = *neq; - for (l = 1; l <= i__2; ++l) { -/* L220: */ - wm[nrow + l] = (e[l] - delta[l]) * delinv; - } - nrow += *neq; - y[i__] = ysave; - yprime[i__] = ypsave; -/* L210: */ - } - - -/* Do dense-matrix LU decomposition on J. */ - -L230: - dgefa_(&wm[1], neq, neq, &iwm[lipvt], ier); - return 0; - - -/* Dummy section for IWM(MTYPE)=3. */ - -L300: - return 0; - - -/* Banded user-supplied matrix. */ - -L400: - lenpd = iwm[22]; - i__1 = lenpd; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L410: */ - wm[i__] = 0.; - } - (*jacd)(x, &y[1], &yprime[1], &wm[1], cj, &rpar[1], &ipar[1]); - meband = (iwm[1] << 1) + iwm[2] + 1; - goto L550; - - -/* Banded finite-difference-generated matrix. */ - -L500: - mband = iwm[1] + iwm[2] + 1; - mba = min(mband,*neq); - meband = mband + iwm[1]; - meb1 = meband - 1; - msave = *neq / mband + 1; - isave = iwm[22]; - ipsave = isave + msave; - *ires = 0; - squr = sqrt(*uround); - i__1 = mba; - for (j = 1; j <= i__1; ++j) { - i__2 = *neq; - i__3 = mband; - for (n = j; i__3 < 0 ? n >= i__2 : n <= i__2; n += i__3) { - k = (n - j) / mband + 1; - wm[isave + k] = y[n]; - wm[ipsave + k] = yprime[n]; -/* Computing MAX */ - d__4 = (d__1 = y[n], abs(d__1)), d__5 = (d__2 = *h__ * yprime[n], - abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = 1. / - ewt[n], abs(d__3)); - del = squr * max(d__4,d__5); - d__1 = *h__ * yprime[n]; - del = d_sign(&del, &d__1); - del = y[n] + del - y[n]; - y[n] += del; -/* L510: */ - yprime[n] += *cj * del; - } - ++iwm[12]; - (*res)(x, &y[1], &yprime[1], cj, &e[1], ires, &rpar[1], &ipar[1]); - if (*ires < 0) { - return 0; - } - i__3 = *neq; - i__2 = mband; - for (n = j; i__2 < 0 ? n >= i__3 : n <= i__3; n += i__2) { - k = (n - j) / mband + 1; - y[n] = wm[isave + k]; - yprime[n] = wm[ipsave + k]; -/* Computing MAX */ - d__4 = (d__1 = y[n], abs(d__1)), d__5 = (d__2 = *h__ * yprime[n], - abs(d__2)), d__4 = max(d__4,d__5), d__5 = (d__3 = 1. / - ewt[n], abs(d__3)); - del = squr * max(d__4,d__5); - d__1 = *h__ * yprime[n]; - del = d_sign(&del, &d__1); - del = y[n] + del - y[n]; - delinv = 1. / del; -/* Computing MAX */ - i__4 = 1, i__5 = n - iwm[2]; - i1 = max(i__4,i__5); -/* Computing MIN */ - i__4 = *neq, i__5 = n + iwm[1]; - i2 = min(i__4,i__5); - ii = n * meb1 - iwm[1]; - i__4 = i2; - for (i__ = i1; i__ <= i__4; ++i__) { -/* L520: */ - wm[ii + i__] = (e[i__] - delta[i__]) * delinv; - } -/* L530: */ - } -/* L540: */ - } - - -/* Do LU decomposition of banded J. */ - -L550: - dgbfa_(&wm[1], &meband, neq, &iwm[1], &iwm[2], &iwm[lipvt], ier); - return 0; - -/* ------END OF SUBROUTINE DMATD------------------------------------------ */ -} /* dmatd_ */ - -/* Subroutine */ int dslvd_(integer *neq, doublereal *delta, doublereal *wm, - integer *iwm) -{ - extern /* Subroutine */ int dgbsl_(doublereal *, integer *, integer *, - integer *, integer *, integer *, doublereal *, integer *), dgesl_( - doublereal *, integer *, integer *, integer *, doublereal *, - integer *); - integer lipvt, mtype, meband; - - -/* ***BEGIN PROLOGUE DSLVD */ -/* ***REFER TO DDASPK */ -/* ***DATE WRITTEN 890101 (YYMMDD) */ -/* ***REVISION DATE 900926 (YYMMDD) */ -/* ***REVISION DATE 940701 (YYMMDD) (new LIPVT) */ - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* This routine manages the solution of the linear */ -/* system arising in the Newton iteration. */ -/* Real matrix information and real temporary storage */ -/* is stored in the array WM. */ -/* Integer matrix information is stored in the array IWM. */ -/* For a dense matrix, the LINPACK routine DGESL is called. */ -/* For a banded matrix, the LINPACK routine DGBSL is called. */ -/* ----------------------------------------------------------------------- */ -/* ***ROUTINES CALLED */ -/* DGESL, DGBSL */ - -/* ***END PROLOGUE DSLVD */ - - - - - /* Parameter adjustments */ - --iwm; - --wm; - --delta; - - /* Function Body */ - lipvt = iwm[30]; - mtype = iwm[4]; - switch (mtype) { - case 1: goto L100; - case 2: goto L100; - case 3: goto L300; - case 4: goto L400; - case 5: goto L400; - } - -/* Dense matrix. */ - -L100: - dgesl_(&wm[1], neq, neq, &iwm[lipvt], &delta[1], &c__0); - return 0; - -/* Dummy section for MTYPE=3. */ - -L300: - return 0; - -/* Banded matrix. */ - -L400: - meband = (iwm[1] << 1) + iwm[2] + 1; - dgbsl_(&wm[1], &meband, neq, &iwm[1], &iwm[2], &iwm[lipvt], &delta[1], & - c__0); - return 0; - -/* ------END OF SUBROUTINE DSLVD------------------------------------------ */ -} /* dslvd_ */ - -/* Subroutine */ int ddasik_(doublereal *x, doublereal *y, doublereal *yprime, - integer *neq, integer *icopt, integer *id, S_fp res, S_fp jack, U_fp - psol, doublereal *h__, doublereal *tscale, doublereal *wt, integer * - jskip, doublereal *rpar, integer *ipar, doublereal *savr, doublereal * - delta, doublereal *r__, doublereal *yic, doublereal *ypic, doublereal - *pwk, doublereal *wm, integer *iwm, doublereal *cj, doublereal * - uround, doublereal *epli, doublereal *sqrtn, doublereal *rsqrtn, - doublereal *epcon, doublereal *ratemx, doublereal *stptol, integer * - jflg, integer *icnflg, integer *icnstr, integer *iernls) -{ - integer nj, lwp, ires, liwp, mxnj; - doublereal eplin; - extern /* Subroutine */ int dnsik_(doublereal *, doublereal *, doublereal - *, integer *, integer *, integer *, S_fp, U_fp, doublereal *, - doublereal *, integer *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer * - , doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, integer *, doublereal *, - integer *, integer *, integer *); - integer ierpj; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); - integer mxnit, iernew; - - -/* ***BEGIN PROLOGUE DDASIK */ -/* ***REFER TO DDASPK */ -/* ***DATE WRITTEN 941026 (YYMMDD) */ -/* ***REVISION DATE 950808 (YYMMDD) */ -/* ***REVISION DATE 951110 Removed unreachable block 390. */ -/* ***REVISION DATE 000628 TSCALE argument added. */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - - -/* DDASIK solves a nonlinear system of algebraic equations of the */ -/* form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in */ -/* the initial conditions. */ - -/* An initial value for Y and initial guess for YPRIME are input. */ - -/* The method used is a Newton scheme with Krylov iteration and a */ -/* linesearch algorithm. */ - -/* The parameters represent */ - -/* X -- Independent variable. */ -/* Y -- Solution vector at x. */ -/* YPRIME -- Derivative of solution vector. */ -/* NEQ -- Number of equations to be integrated. */ -/* ICOPT -- Initial condition option chosen (1 or 2). */ -/* ID -- Array of dimension NEQ, which must be initialized */ -/* if ICOPT = 1. See DDASIC. */ -/* RES -- External user-supplied subroutine */ -/* to evaluate the residual. See RES description */ -/* in DDASPK prologue. */ -/* JACK -- External user-supplied routine to update */ -/* the preconditioner. (This is optional). */ -/* See JAC description for the case */ -/* INFO(12) = 1 in the DDASPK prologue. */ -/* PSOL -- External user-supplied routine to solve */ -/* a linear system using preconditioning. */ -/* (This is optional). See explanation inside DDASPK. */ -/* H -- Scaling factor for this initial condition calc. */ -/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ -/* WT -- Vector of weights for error criterion. */ -/* JSKIP -- input flag to signal if initial JAC call is to be */ -/* skipped. 1 => skip the call, 0 => do not skip call. */ -/* RPAR,IPAR -- Real and integer arrays used for communication */ -/* between the calling program and external user */ -/* routines. They are not altered within DASPK. */ -/* SAVR -- Work vector for DDASIK of length NEQ. */ -/* DELTA -- Work vector for DDASIK of length NEQ. */ -/* R -- Work vector for DDASIK of length NEQ. */ -/* YIC,YPIC -- Work vectors for DDASIK, each of length NEQ. */ -/* PWK -- Work vector for DDASIK of length NEQ. */ -/* WM,IWM -- Real and integer arrays storing */ -/* matrix information for linear system */ -/* solvers, and various other information. */ -/* CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). */ -/* UROUND -- Unit roundoff. Not used here. */ -/* EPLI -- convergence test constant. */ -/* See DDASPK prologue for more details. */ -/* SQRTN -- Square root of NEQ. */ -/* RSQRTN -- reciprical of square root of NEQ. */ -/* EPCON -- Tolerance to test for convergence of the Newton */ -/* iteration. */ -/* RATEMX -- Maximum convergence rate for which Newton iteration */ -/* is considered converging. */ -/* JFLG -- Flag showing whether a Jacobian routine is supplied. */ -/* ICNFLG -- Integer scalar. If nonzero, then constraint */ -/* violations in the proposed new approximate solution */ -/* will be checked for, and the maximum step length */ -/* will be adjusted accordingly. */ -/* ICNSTR -- Integer array of length NEQ containing flags for */ -/* checking constraints. */ -/* IERNLS -- Error flag for nonlinear solver. */ -/* 0 ==> nonlinear solver converged. */ -/* 1,2 ==> recoverable error inside nonlinear solver. */ -/* 1 => retry with current Y, YPRIME */ -/* 2 => retry with original Y, YPRIME */ -/* -1 ==> unrecoverable error in nonlinear solver. */ - -/* ----------------------------------------------------------------------- */ - -/* ***ROUTINES CALLED */ -/* RES, JACK, DNSIK, DCOPY */ - -/* ***END PROLOGUE DDASIK */ - - - - - -/* Perform initializations. */ - - /* Parameter adjustments */ - --icnstr; - --iwm; - --wm; - --pwk; - --ypic; - --yic; - --r__; - --delta; - --savr; - --ipar; - --rpar; - --wt; - --id; - --yprime; - --y; - - /* Function Body */ - lwp = iwm[29]; - liwp = iwm[30]; - mxnit = iwm[32]; - mxnj = iwm[33]; - *iernls = 0; - nj = 0; - eplin = *epli * *epcon; - -/* Call RES to initialize DELTA. */ - - ires = 0; - ++iwm[12]; - (*res)(x, &y[1], &yprime[1], cj, &delta[1], &ires, &rpar[1], &ipar[1]); - if (ires < 0) { - goto L370; - } - -/* Looping point for updating the preconditioner. */ - -L300: - -/* Initialize all error flags to zero. */ - - ierpj = 0; - ires = 0; - iernew = 0; - -/* If a Jacobian routine was supplied, call it. */ - - if (*jflg == 1 && *jskip == 0) { - ++nj; - ++iwm[13]; - (*jack)((S_fp)res, &ires, neq, x, &y[1], &yprime[1], &wt[1], &delta[1] - , &r__[1], h__, cj, &wm[lwp], &iwm[liwp], &ierpj, &rpar[1], & - ipar[1]); - if (ires < 0 || ierpj != 0) { - goto L370; - } - } - *jskip = 0; - -/* Call the nonlinear Newton solver for up to MXNIT iterations. */ - - dnsik_(x, &y[1], &yprime[1], neq, icopt, &id[1], (S_fp)res, (U_fp)psol, & - wt[1], &rpar[1], &ipar[1], &savr[1], &delta[1], &r__[1], &yic[1], - &ypic[1], &pwk[1], &wm[1], &iwm[1], cj, tscale, sqrtn, rsqrtn, & - eplin, epcon, ratemx, &mxnit, stptol, icnflg, &icnstr[1], &iernew) - ; - - if (iernew == 1 && nj < mxnj && *jflg == 1) { - -/* Up to MXNIT iterations were done, the convergence rate is < 1, */ -/* a Jacobian routine is supplied, and the number of JACK calls */ -/* is less than MXNJ. */ -/* Copy the residual SAVR to DELTA, call JACK, and try again. */ - - dcopy_(neq, &savr[1], &c__1, &delta[1], &c__1); - goto L300; - } - - if (iernew != 0) { - goto L380; - } - return 0; - - -/* Unsuccessful exits from nonlinear solver. */ -/* Set IERNLS accordingly. */ - -L370: - *iernls = 2; - if (ires <= -2) { - *iernls = -1; - } - return 0; - -L380: - *iernls = min(iernew,2); - return 0; - -/* ----------------------- END OF SUBROUTINE DDASIK----------------------- */ -} /* ddasik_ */ - -/* Subroutine */ int dnsik_(doublereal *x, doublereal *y, doublereal *yprime, - integer *neq, integer *icopt, integer *id, S_fp res, U_fp psol, - doublereal *wt, doublereal *rpar, integer *ipar, doublereal *savr, - doublereal *delta, doublereal *r__, doublereal *yic, doublereal *ypic, - doublereal *pwk, doublereal *wm, integer *iwm, doublereal *cj, - doublereal *tscale, doublereal *sqrtn, doublereal *rsqrtn, doublereal - *eplin, doublereal *epcon, doublereal *ratemx, integer *maxit, - doublereal *stptol, integer *icnflg, integer *icnstr, integer *iernew) -{ - integer m, ier, lwp; - doublereal rlx, rate; - integer ires; - doublereal fnrm, rhok; - integer iret, liwp; - doublereal fnrm0; - integer lsoff; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); - integer iersl; - extern /* Subroutine */ int dslvk_(integer *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *, S_fp, integer *, U_fp, integer *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, integer *); - doublereal oldfnm; - extern /* Subroutine */ int dfnrmk_(integer *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, S_fp, - integer *, U_fp, integer *, integer *, doublereal *, doublereal *, - doublereal *, integer *, doublereal *, doublereal *, integer *); - doublereal delnrm; - extern /* Subroutine */ int dlinsk_(integer *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *, doublereal *, integer *, S_fp, integer *, - U_fp, doublereal *, integer *, doublereal *, doublereal *, - integer *, integer *, doublereal *, integer *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *, - integer *, doublereal *, doublereal *, integer *); - extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, - doublereal *, integer *); - - -/* ***BEGIN PROLOGUE DNSIK */ -/* ***REFER TO DDASPK */ -/* ***DATE WRITTEN 940701 (YYMMDD) */ -/* ***REVISION DATE 950714 (YYMMDD) */ -/* ***REVISION DATE 000628 TSCALE argument added. */ -/* ***REVISION DATE 000628 Added criterion for IERNEW = 1 return. */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* DNSIK solves a nonlinear system of algebraic equations of the */ -/* form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in */ -/* the initial conditions. */ - -/* The method used is a Newton scheme combined with a linesearch */ -/* algorithm, using Krylov iterative linear system methods. */ - -/* The parameters represent */ - -/* X -- Independent variable. */ -/* Y -- Solution vector. */ -/* YPRIME -- Derivative of solution vector. */ -/* NEQ -- Number of unknowns. */ -/* ICOPT -- Initial condition option chosen (1 or 2). */ -/* ID -- Array of dimension NEQ, which must be initialized */ -/* if ICOPT = 1. See DDASIC. */ -/* RES -- External user-supplied subroutine */ -/* to evaluate the residual. See RES description */ -/* in DDASPK prologue. */ -/* PSOL -- External user-supplied routine to solve */ -/* a linear system using preconditioning. */ -/* See explanation inside DDASPK. */ -/* WT -- Vector of weights for error criterion. */ -/* RPAR,IPAR -- Real and integer arrays used for communication */ -/* between the calling program and external user */ -/* routines. They are not altered within DASPK. */ -/* SAVR -- Work vector for DNSIK of length NEQ. */ -/* DELTA -- Residual vector on entry, and work vector of */ -/* length NEQ for DNSIK. */ -/* R -- Work vector for DNSIK of length NEQ. */ -/* YIC,YPIC -- Work vectors for DNSIK, each of length NEQ. */ -/* PWK -- Work vector for DNSIK of length NEQ. */ -/* WM,IWM -- Real and integer arrays storing */ -/* matrix information such as the matrix */ -/* of partial derivatives, permutation */ -/* vector, and various other information. */ -/* CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). */ -/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ -/* SQRTN -- Square root of NEQ. */ -/* RSQRTN -- reciprical of square root of NEQ. */ -/* EPLIN -- Tolerance for linear system solver. */ -/* EPCON -- Tolerance to test for convergence of the Newton */ -/* iteration. */ -/* RATEMX -- Maximum convergence rate for which Newton iteration */ -/* is considered converging. */ -/* MAXIT -- Maximum allowed number of Newton iterations. */ -/* STPTOL -- Tolerance used in calculating the minimum lambda */ -/* value allowed. */ -/* ICNFLG -- Integer scalar. If nonzero, then constraint */ -/* violations in the proposed new approximate solution */ -/* will be checked for, and the maximum step length */ -/* will be adjusted accordingly. */ -/* ICNSTR -- Integer array of length NEQ containing flags for */ -/* checking constraints. */ -/* IERNEW -- Error flag for Newton iteration. */ -/* 0 ==> Newton iteration converged. */ -/* 1 ==> failed to converge, but RATE .lt. 1, or the */ -/* residual norm was reduced by a factor of .1. */ -/* 2 ==> failed to converge, RATE .gt. RATEMX. */ -/* 3 ==> other recoverable error. */ -/* -1 ==> unrecoverable error inside Newton iteration. */ -/* ----------------------------------------------------------------------- */ - -/* ***ROUTINES CALLED */ -/* DFNRMK, DSLVK, DDWNRM, DLINSK, DCOPY */ - -/* ***END PROLOGUE DNSIK */ - - - - - -/* Initializations. M is the Newton iteration counter. */ - - /* Parameter adjustments */ - --icnstr; - --iwm; - --wm; - --pwk; - --ypic; - --yic; - --r__; - --delta; - --savr; - --ipar; - --rpar; - --wt; - --id; - --yprime; - --y; - - /* Function Body */ - lsoff = iwm[35]; - m = 0; - rate = 1.; - lwp = iwm[29]; - liwp = iwm[30]; - rlx = .4; - -/* Save residual in SAVR. */ - - dcopy_(neq, &delta[1], &c__1, &savr[1], &c__1); - -/* Compute norm of (P-inverse)*(residual). */ - - dfnrmk_(neq, &y[1], x, &yprime[1], &savr[1], &r__[1], cj, tscale, &wt[1], - sqrtn, rsqrtn, (S_fp)res, &ires, (U_fp)psol, &c__1, &ier, &fnrm, - eplin, &wm[lwp], &iwm[liwp], &pwk[1], &rpar[1], &ipar[1]); - ++iwm[21]; - if (ier != 0) { - *iernew = 3; - return 0; - } - -/* Return now if residual norm is .le. EPCON. */ - - if (fnrm <= *epcon) { - return 0; - } - -/* Newton iteration loop. */ - - fnrm0 = fnrm; -L300: - ++iwm[19]; - -/* Compute a new step vector DELTA. */ - - dslvk_(neq, &y[1], x, &yprime[1], &savr[1], &delta[1], &wt[1], &wm[1], & - iwm[1], (S_fp)res, &ires, (U_fp)psol, &iersl, cj, eplin, sqrtn, - rsqrtn, &rhok, &rpar[1], &ipar[1]); - if (ires != 0 || iersl != 0) { - goto L390; - } - -/* Get norm of DELTA. Return now if DELTA is zero. */ - - delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); - if (delnrm == 0.) { - return 0; - } - -/* Call linesearch routine for global strategy and set RATE. */ - - oldfnm = fnrm; - - dlinsk_(neq, &y[1], x, &yprime[1], &savr[1], cj, tscale, &delta[1], & - delnrm, &wt[1], sqrtn, rsqrtn, &lsoff, stptol, &iret, (S_fp)res, & - ires, (U_fp)psol, &wm[1], &iwm[1], &rhok, &fnrm, icopt, &id[1], & - wm[lwp], &iwm[liwp], &r__[1], eplin, &yic[1], &ypic[1], &pwk[1], - icnflg, &icnstr[1], &rlx, &rpar[1], &ipar[1]); - - rate = fnrm / oldfnm; - -/* Check for error condition from linesearch. */ - if (iret != 0) { - goto L390; - } - -/* Test for convergence of the iteration, and return or loop. */ - - if (fnrm <= *epcon) { - return 0; - } - -/* The iteration has not yet converged. Update M. */ -/* Test whether the maximum number of iterations have been tried. */ - - ++m; - if (m >= *maxit) { - goto L380; - } - -/* Copy the residual SAVR to DELTA and loop for another iteration. */ - - dcopy_(neq, &savr[1], &c__1, &delta[1], &c__1); - goto L300; - -/* The maximum number of iterations was done. Set IERNEW and return. */ - -L380: - if (rate <= *ratemx || fnrm <= fnrm0 * .1) { - *iernew = 1; - } else { - *iernew = 2; - } - return 0; - -L390: - if (ires <= -2 || iersl < 0) { - *iernew = -1; - } else { - *iernew = 3; - if (ires == 0 && iersl == 1 && m >= 2 && rate < 1.) { - *iernew = 1; - } - } - return 0; - - -/* ----------------------- END OF SUBROUTINE DNSIK------------------------ */ -} /* dnsik_ */ - -/* Subroutine */ int dlinsk_(integer *neq, doublereal *y, doublereal *t, - doublereal *yprime, doublereal *savr, doublereal *cj, doublereal * - tscale, doublereal *p, doublereal *pnrm, doublereal *wt, doublereal * - sqrtn, doublereal *rsqrtn, integer *lsoff, doublereal *stptol, - integer *iret, S_fp res, integer *ires, U_fp psol, doublereal *wm, - integer *iwm, doublereal *rhok, doublereal *fnrm, integer *icopt, - integer *id, doublereal *wp, integer *iwp, doublereal *r__, - doublereal *eplin, doublereal *ynew, doublereal *ypnew, doublereal * - pwk, integer *icnflg, integer *icnstr, doublereal *rlx, doublereal * - rpar, integer *ipar) -{ - /* Initialized data */ - - static doublereal alpha = 1e-4; - static doublereal one = 1.; - static doublereal two = 2.; - - /* System generated locals */ - integer i__1; - - /* Builtin functions */ - /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); - - /* Local variables */ - integer i__; - doublereal rl; - integer ier; - char msg[80]; - doublereal tau; - integer ivar; - doublereal slpi, f1nrm, ratio; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); - doublereal rlmin, fnrmp; - integer kprin; - doublereal ratio1, f1nrmp; - extern /* Subroutine */ int dfnrmk_(integer *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, S_fp, - integer *, U_fp, integer *, integer *, doublereal *, doublereal *, - doublereal *, integer *, doublereal *, doublereal *, integer *), - dcnstr_(integer *, doublereal *, doublereal *, integer *, - doublereal *, doublereal *, integer *, integer *), xerrwd_(char *, - integer *, integer *, integer *, integer *, integer *, integer *, - integer *, doublereal *, doublereal *, ftnlen), dyypnw_(integer * - , doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *, integer *, doublereal *, doublereal *); - - -/* ***BEGIN PROLOGUE DLINSK */ -/* ***REFER TO DNSIK */ -/* ***DATE WRITTEN 940830 (YYMMDD) */ -/* ***REVISION DATE 951006 (Arguments SQRTN, RSQRTN added.) */ -/* ***REVISION DATE 960129 Moved line RL = ONE to top block. */ -/* ***REVISION DATE 000628 TSCALE argument added. */ -/* ***REVISION DATE 000628 RHOK*RHOK term removed in alpha test. */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* DLINSK uses a linesearch algorithm to calculate a new (Y,YPRIME) */ -/* pair (YNEW,YPNEW) such that */ - -/* f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) */ - -/* where 0 < RL <= 1, and RHOK is the scaled preconditioned norm of */ -/* the final residual vector in the Krylov iteration. */ -/* Here, f(y,y') is defined as */ - -/* f(y,y') = (1/2)*norm( (P-inverse)*G(t,y,y') )**2 , */ - -/* where norm() is the weighted RMS vector norm, G is the DAE */ -/* system residual function, and P is the preconditioner used */ -/* in the Krylov iteration. */ - -/* In addition to the parameters defined elsewhere, we have */ - -/* SAVR -- Work array of length NEQ, containing the residual */ -/* vector G(t,y,y') on return. */ -/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ -/* P -- Approximate Newton step used in backtracking. */ -/* PNRM -- Weighted RMS norm of P. */ -/* LSOFF -- Flag showing whether the linesearch algorithm is */ -/* to be invoked. 0 means do the linesearch, */ -/* 1 means turn off linesearch. */ -/* STPTOL -- Tolerance used in calculating the minimum lambda */ -/* value allowed. */ -/* ICNFLG -- Integer scalar. If nonzero, then constraint violations */ -/* in the proposed new approximate solution will be */ -/* checked for, and the maximum step length will be */ -/* adjusted accordingly. */ -/* ICNSTR -- Integer array of length NEQ containing flags for */ -/* checking constraints. */ -/* RHOK -- Weighted norm of preconditioned Krylov residual. */ -/* RLX -- Real scalar restricting update size in DCNSTR. */ -/* YNEW -- Array of length NEQ used to hold the new Y in */ -/* performing the linesearch. */ -/* YPNEW -- Array of length NEQ used to hold the new YPRIME in */ -/* performing the linesearch. */ -/* PWK -- Work vector of length NEQ for use in PSOL. */ -/* Y -- Array of length NEQ containing the new Y (i.e.,=YNEW). */ -/* YPRIME -- Array of length NEQ containing the new YPRIME */ -/* (i.e.,=YPNEW). */ -/* FNRM -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the */ -/* current (Y,YPRIME) on input and output. */ -/* R -- Work space length NEQ for residual vector. */ -/* IRET -- Return flag. */ -/* IRET=0 means that a satisfactory (Y,YPRIME) was found. */ -/* IRET=1 means that the routine failed to find a new */ -/* (Y,YPRIME) that was sufficiently distinct from */ -/* the current (Y,YPRIME) pair. */ -/* IRET=2 means a failure in RES or PSOL. */ -/* ----------------------------------------------------------------------- */ - -/* ***ROUTINES CALLED */ -/* DFNRMK, DYYPNW, DCNSTR, DCOPY, XERRWD */ - -/* ***END PROLOGUE DLINSK */ - - - - /* Parameter adjustments */ - --ipar; - --rpar; - --icnstr; - --pwk; - --ypnew; - --ynew; - --r__; - --iwp; - --wp; - --id; - --iwm; - --wm; - --wt; - --p; - --savr; - --yprime; - --y; - - /* Function Body */ - - kprin = iwm[31]; - f1nrm = *fnrm * *fnrm / two; - ratio = one; - - if (kprin >= 2) { - s_copy(msg, "------ IN ROUTINE DLINSK-- PNRM = (R1)", (ftnlen)80, ( - ftnlen)38); - xerrwd_(msg, &c__38, &c__921, &c__0, &c__0, &c__0, &c__0, &c__1, pnrm, - &c_b37, (ftnlen)80); - } - tau = *pnrm; - rl = one; -/* ----------------------------------------------------------------------- */ -/* Check for violations of the constraints, if any are imposed. */ -/* If any violations are found, the step vector P is rescaled, and the */ -/* constraint check is repeated, until no violations are found. */ -/* ----------------------------------------------------------------------- */ - if (*icnflg != 0) { -L10: - dyypnw_(neq, &y[1], &yprime[1], cj, &rl, &p[1], icopt, &id[1], &ynew[ - 1], &ypnew[1]); - dcnstr_(neq, &y[1], &ynew[1], &icnstr[1], &tau, rlx, iret, &ivar); - if (*iret == 1) { - ratio1 = tau / *pnrm; - ratio *= ratio1; - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L20: */ - p[i__] *= ratio1; - } - *pnrm = tau; - if (kprin >= 2) { - s_copy(msg, "------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (" - "I1)", (ftnlen)80, (ftnlen)50); - xerrwd_(msg, &c__50, &c__922, &c__0, &c__1, &ivar, &c__0, & - c__1, pnrm, &c_b37, (ftnlen)80); - } - if (*pnrm <= *stptol) { - *iret = 1; - return 0; - } - goto L10; - } - } - - slpi = -two * f1nrm * ratio; - rlmin = *stptol / *pnrm; - if (*lsoff == 0 && kprin >= 2) { - s_copy(msg, "------ MIN. LAMBDA = (R1)", (ftnlen)80, (ftnlen)25); - xerrwd_(msg, &c__25, &c__923, &c__0, &c__0, &c__0, &c__0, &c__1, & - rlmin, &c_b37, (ftnlen)80); - } -/* ----------------------------------------------------------------------- */ -/* Begin iteration to find RL value satisfying alpha-condition. */ -/* Update YNEW and YPNEW, then compute norm of new scaled residual and */ -/* perform alpha condition test. */ -/* ----------------------------------------------------------------------- */ -L100: - dyypnw_(neq, &y[1], &yprime[1], cj, &rl, &p[1], icopt, &id[1], &ynew[1], & - ypnew[1]); - dfnrmk_(neq, &ynew[1], t, &ypnew[1], &savr[1], &r__[1], cj, tscale, &wt[1] - , sqrtn, rsqrtn, (S_fp)res, ires, (U_fp)psol, &c__0, &ier, &fnrmp, - eplin, &wp[1], &iwp[1], &pwk[1], &rpar[1], &ipar[1]); - ++iwm[12]; - if (*ires >= 0) { - ++iwm[21]; - } - if (*ires != 0 || ier != 0) { - *iret = 2; - return 0; - } - if (*lsoff == 1) { - goto L150; - } - - f1nrmp = fnrmp * fnrmp / two; - if (kprin >= 2) { - s_copy(msg, "------ LAMBDA = (R1)", (ftnlen)80, (ftnlen)20); - xerrwd_(msg, &c__20, &c__924, &c__0, &c__0, &c__0, &c__0, &c__1, &rl, - &c_b37, (ftnlen)80); - s_copy(msg, "------ NORM(F1) = (R1), NORM(F1NEW) = (R2)", (ftnlen)80, - (ftnlen)43); - xerrwd_(msg, &c__43, &c__925, &c__0, &c__0, &c__0, &c__0, &c__2, & - f1nrm, &f1nrmp, (ftnlen)80); - } - if (f1nrmp > f1nrm + alpha * slpi * rl) { - goto L200; - } -/* ----------------------------------------------------------------------- */ -/* Alpha-condition is satisfied, or linesearch is turned off. */ -/* Copy YNEW,YPNEW to Y,YPRIME and return. */ -/* ----------------------------------------------------------------------- */ -L150: - *iret = 0; - dcopy_(neq, &ynew[1], &c__1, &y[1], &c__1); - dcopy_(neq, &ypnew[1], &c__1, &yprime[1], &c__1); - *fnrm = fnrmp; - if (kprin >= 1) { - s_copy(msg, "------ LEAVING ROUTINE DLINSK, FNRM = (R1)", (ftnlen)80, - (ftnlen)42); - xerrwd_(msg, &c__42, &c__926, &c__0, &c__0, &c__0, &c__0, &c__1, fnrm, - &c_b37, (ftnlen)80); - } - return 0; -/* ----------------------------------------------------------------------- */ -/* Alpha-condition not satisfied. Perform backtrack to compute new RL */ -/* value. If RL is less than RLMIN, i.e. no satisfactory YNEW,YPNEW can */ -/* be found sufficiently distinct from Y,YPRIME, then return IRET = 1. */ -/* ----------------------------------------------------------------------- */ -L200: - if (rl < rlmin) { - *iret = 1; - return 0; - } - - rl /= two; - goto L100; - -/* ----------------------- END OF SUBROUTINE DLINSK ---------------------- */ -} /* dlinsk_ */ - -/* Subroutine */ int dfnrmk_(integer *neq, doublereal *y, doublereal *t, - doublereal *yprime, doublereal *savr, doublereal *r__, doublereal *cj, - doublereal *tscale, doublereal *wt, doublereal *sqrtn, doublereal * - rsqrtn, S_fp res, integer *ires, S_fp psol, integer *irin, integer * - ier, doublereal *fnorm, doublereal *eplin, doublereal *wp, integer * - iwp, doublereal *pwk, doublereal *rpar, integer *ipar) -{ - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dcopy_(integer *, doublereal *, integer *, doublereal - *, integer *); - extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, - doublereal *, integer *); - - -/* ***BEGIN PROLOGUE DFNRMK */ -/* ***REFER TO DLINSK */ -/* ***DATE WRITTEN 940830 (YYMMDD) */ -/* ***REVISION DATE 951006 (SQRTN, RSQRTN, and scaling of WT added.) */ -/* ***REVISION DATE 000628 TSCALE argument added. */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* DFNRMK calculates the scaled preconditioned norm of the nonlinear */ -/* function used in the nonlinear iteration for obtaining consistent */ -/* initial conditions. Specifically, DFNRMK calculates the weighted */ -/* root-mean-square norm of the vector (P-inverse)*G(T,Y,YPRIME), */ -/* where P is the preconditioner matrix. */ - -/* In addition to the parameters described in the calling program */ -/* DLINSK, the parameters represent */ - -/* TSCALE -- Scale factor in T, used for stopping tests if nonzero. */ -/* IRIN -- Flag showing whether the current residual vector is */ -/* input in SAVR. 1 means it is, 0 means it is not. */ -/* R -- Array of length NEQ that contains */ -/* (P-inverse)*G(T,Y,YPRIME) on return. */ -/* FNORM -- Scalar containing the weighted norm of R on return. */ -/* ----------------------------------------------------------------------- */ - -/* ***ROUTINES CALLED */ -/* RES, DCOPY, DSCAL, PSOL, DDWNRM */ - -/* ***END PROLOGUE DFNRMK */ - - -/* ----------------------------------------------------------------------- */ -/* Call RES routine if IRIN = 0. */ -/* ----------------------------------------------------------------------- */ - /* Parameter adjustments */ - --ipar; - --rpar; - --pwk; - --iwp; - --wp; - --wt; - --r__; - --savr; - --yprime; - --y; - - /* Function Body */ - if (*irin == 0) { - *ires = 0; - (*res)(t, &y[1], &yprime[1], cj, &savr[1], ires, &rpar[1], &ipar[1]); - if (*ires < 0) { - return 0; - } - } -/* ----------------------------------------------------------------------- */ -/* Apply inverse of left preconditioner to vector R. */ -/* First scale WT array by 1/sqrt(N), and undo scaling afterward. */ -/* ----------------------------------------------------------------------- */ - dcopy_(neq, &savr[1], &c__1, &r__[1], &c__1); - dscal_(neq, rsqrtn, &wt[1], &c__1); - *ier = 0; - (*psol)(neq, t, &y[1], &yprime[1], &savr[1], &pwk[1], cj, &wt[1], &wp[1], - &iwp[1], &r__[1], eplin, ier, &rpar[1], &ipar[1]); - dscal_(neq, sqrtn, &wt[1], &c__1); - if (*ier != 0) { - return 0; - } -/* ----------------------------------------------------------------------- */ -/* Calculate norm of R. */ -/* ----------------------------------------------------------------------- */ - *fnorm = ddwnrm_(neq, &r__[1], &wt[1], &rpar[1], &ipar[1]); - if (*tscale > 0.) { - *fnorm = *fnorm * *tscale * abs(*cj); - } - - return 0; -/* ----------------------- END OF SUBROUTINE DFNRMK ---------------------- */ -} /* dfnrmk_ */ - -/* Subroutine */ int dnedk_(doublereal *x, doublereal *y, doublereal *yprime, - integer *neq, S_fp res, S_fp jack, U_fp psol, doublereal *h__, - doublereal *wt, integer *jstart, integer *idid, doublereal *rpar, - integer *ipar, doublereal *phi, doublereal *gamma, doublereal *savr, - doublereal *delta, doublereal *e, doublereal *wm, integer *iwm, - doublereal *cj, doublereal *cjold, doublereal *cjlast, doublereal *s, - doublereal *uround, doublereal *epli, doublereal *sqrtn, doublereal * - rsqrtn, doublereal *epcon, integer *jcalc, integer *jflg, integer * - kp1, integer *nonneg, integer *ntype, integer *iernls) -{ - /* Initialized data */ - - static integer muldel = 0; - static integer maxit = 4; - static doublereal xrate = .25; - - /* System generated locals */ - integer phi_dim1, phi_offset, i__1, i__2; - doublereal d__1; - - /* Local variables */ - integer i__, j, lwp; - extern /* Subroutine */ int dnsk_(doublereal *, doublereal *, doublereal * - , integer *, S_fp, U_fp, doublereal *, doublereal *, integer *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer *, - integer *, integer *, integer *, integer *); - integer ires, liwp; - doublereal temp1, temp2, eplin; - integer ierpj, iersl; - doublereal delnrm; - integer iernew; - extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, - doublereal *, integer *); - doublereal tolnew; - integer iertyp; - - -/* ***BEGIN PROLOGUE DNEDK */ -/* ***REFER TO DDASPK */ -/* ***DATE WRITTEN 891219 (YYMMDD) */ -/* ***REVISION DATE 900926 (YYMMDD) */ -/* ***REVISION DATE 940701 (YYMMDD) */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* DNEDK solves a nonlinear system of */ -/* algebraic equations of the form */ -/* G(X,Y,YPRIME) = 0 for the unknown Y. */ - -/* The method used is a matrix-free Newton scheme. */ - -/* The parameters represent */ -/* X -- Independent variable. */ -/* Y -- Solution vector at x. */ -/* YPRIME -- Derivative of solution vector */ -/* after successful step. */ -/* NEQ -- Number of equations to be integrated. */ -/* RES -- External user-supplied subroutine */ -/* to evaluate the residual. See RES description */ -/* in DDASPK prologue. */ -/* JACK -- External user-supplied routine to update */ -/* the preconditioner. (This is optional). */ -/* See JAC description for the case */ -/* INFO(12) = 1 in the DDASPK prologue. */ -/* PSOL -- External user-supplied routine to solve */ -/* a linear system using preconditioning. */ -/* (This is optional). See explanation inside DDASPK. */ -/* H -- Appropriate step size for this step. */ -/* WT -- Vector of weights for error criterion. */ -/* JSTART -- Indicates first call to this routine. */ -/* If JSTART = 0, then this is the first call, */ -/* otherwise it is not. */ -/* IDID -- Completion flag, output by DNEDK. */ -/* See IDID description in DDASPK prologue. */ -/* RPAR,IPAR -- Real and integer arrays used for communication */ -/* between the calling program and external user */ -/* routines. They are not altered within DASPK. */ -/* PHI -- Array of divided differences used by */ -/* DNEDK. The length is NEQ*(K+1), where */ -/* K is the maximum order. */ -/* GAMMA -- Array used to predict Y and YPRIME. The length */ -/* is K+1, where K is the maximum order. */ -/* SAVR -- Work vector for DNEDK of length NEQ. */ -/* DELTA -- Work vector for DNEDK of length NEQ. */ -/* E -- Error accumulation vector for DNEDK of length NEQ. */ -/* WM,IWM -- Real and integer arrays storing */ -/* matrix information for linear system */ -/* solvers, and various other information. */ -/* CJ -- Parameter always proportional to 1/H. */ -/* CJOLD -- Saves the value of CJ as of the last call to DITMD. */ -/* Accounts for changes in CJ needed to */ -/* decide whether to call DITMD. */ -/* CJLAST -- Previous value of CJ. */ -/* S -- A scalar determined by the approximate rate */ -/* of convergence of the Newton iteration and used */ -/* in the convergence test for the Newton iteration. */ - -/* If RATE is defined to be an estimate of the */ -/* rate of convergence of the Newton iteration, */ -/* then S = RATE/(1.D0-RATE). */ - -/* The closer RATE is to 0., the faster the Newton */ -/* iteration is converging; the closer RATE is to 1., */ -/* the slower the Newton iteration is converging. */ - -/* On the first Newton iteration with an up-dated */ -/* preconditioner S = 100.D0, Thus the initial */ -/* RATE of convergence is approximately 1. */ - -/* S is preserved from call to call so that the rate */ -/* estimate from a previous step can be applied to */ -/* the current step. */ -/* UROUND -- Unit roundoff. Not used here. */ -/* EPLI -- convergence test constant. */ -/* See DDASPK prologue for more details. */ -/* SQRTN -- Square root of NEQ. */ -/* RSQRTN -- reciprical of square root of NEQ. */ -/* EPCON -- Tolerance to test for convergence of the Newton */ -/* iteration. */ -/* JCALC -- Flag used to determine when to update */ -/* the Jacobian matrix. In general: */ - -/* JCALC = -1 ==> Call the DITMD routine to update */ -/* the Jacobian matrix. */ -/* JCALC = 0 ==> Jacobian matrix is up-to-date. */ -/* JCALC = 1 ==> Jacobian matrix is out-dated, */ -/* but DITMD will not be called unless */ -/* JCALC is set to -1. */ -/* JFLG -- Flag showing whether a Jacobian routine is supplied. */ -/* KP1 -- The current order + 1; updated across calls. */ -/* NONNEG -- Flag to determine nonnegativity constraints. */ -/* NTYPE -- Identification code for the DNEDK routine. */ -/* 1 ==> modified Newton; iterative linear solver. */ -/* 2 ==> modified Newton; user-supplied linear solver. */ -/* IERNLS -- Error flag for nonlinear solver. */ -/* 0 ==> nonlinear solver converged. */ -/* 1 ==> recoverable error inside non-linear solver. */ -/* -1 ==> unrecoverable error inside non-linear solver. */ - -/* The following group of variables are passed as arguments to */ -/* the Newton iteration solver. They are explained in greater detail */ -/* in DNSK: */ -/* TOLNEW, MULDEL, MAXIT, IERNEW */ - -/* IERTYP -- Flag which tells whether this subroutine is correct. */ -/* 0 ==> correct subroutine. */ -/* 1 ==> incorrect subroutine. */ - -/* ----------------------------------------------------------------------- */ -/* ***ROUTINES CALLED */ -/* RES, JACK, DDWNRM, DNSK */ - -/* ***END PROLOGUE DNEDK */ - - - - - /* Parameter adjustments */ - --y; - --yprime; - phi_dim1 = *neq; - phi_offset = 1 + phi_dim1; - phi -= phi_offset; - --wt; - --rpar; - --ipar; - --gamma; - --savr; - --delta; - --e; - --wm; - --iwm; - - /* Function Body */ - -/* Verify that this is the correct subroutine. */ - - iertyp = 0; - if (*ntype != 1) { - iertyp = 1; - goto L380; - } - -/* If this is the first step, perform initializations. */ - - if (*jstart == 0) { - *cjold = *cj; - *jcalc = -1; - *s = 100.; - } - -/* Perform all other initializations. */ - - *iernls = 0; - lwp = iwm[29]; - liwp = iwm[30]; - -/* Decide whether to update the preconditioner. */ - - if (*jflg != 0) { - temp1 = (1. - xrate) / (xrate + 1.); - temp2 = 1. / temp1; - if (*cj / *cjold < temp1 || *cj / *cjold > temp2) { - *jcalc = -1; - } - if (*cj != *cjlast) { - *s = 100.; - } - } else { - *jcalc = 0; - } - -/* Looping point for updating preconditioner with current stepsize. */ - -L300: - -/* Initialize all error flags to zero. */ - - ierpj = 0; - ires = 0; - iersl = 0; - iernew = 0; - -/* Predict the solution and derivative and compute the tolerance */ -/* for the Newton iteration. */ - - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] = phi[i__ + phi_dim1]; -/* L310: */ - yprime[i__] = 0.; - } - i__1 = *kp1; - for (j = 2; j <= i__1; ++j) { - i__2 = *neq; - for (i__ = 1; i__ <= i__2; ++i__) { - y[i__] += phi[i__ + j * phi_dim1]; -/* L320: */ - yprime[i__] += gamma[j] * phi[i__ + j * phi_dim1]; - } -/* L330: */ - } - eplin = *epli * *epcon; - tolnew = eplin; - -/* Call RES to initialize DELTA. */ - - ++iwm[12]; - (*res)(x, &y[1], &yprime[1], cj, &delta[1], &ires, &rpar[1], &ipar[1]); - if (ires < 0) { - goto L380; - } - - -/* If indicated, update the preconditioner. */ -/* Set JCALC to 0 as an indicator that this has been done. */ - - if (*jcalc == -1) { - ++iwm[13]; - *jcalc = 0; - (*jack)((S_fp)res, &ires, neq, x, &y[1], &yprime[1], &wt[1], &delta[1] - , &e[1], h__, cj, &wm[lwp], &iwm[liwp], &ierpj, &rpar[1], & - ipar[1]); - *cjold = *cj; - *s = 100.; - if (ires < 0) { - goto L380; - } - if (ierpj != 0) { - goto L380; - } - } - -/* Call the nonlinear Newton solver. */ - - dnsk_(x, &y[1], &yprime[1], neq, (S_fp)res, (U_fp)psol, &wt[1], &rpar[1], - &ipar[1], &savr[1], &delta[1], &e[1], &wm[1], &iwm[1], cj, sqrtn, - rsqrtn, &eplin, epcon, s, &temp1, &tolnew, &muldel, &maxit, &ires, - &iersl, &iernew); - - if (iernew > 0 && *jcalc != 0) { - -/* The Newton iteration had a recoverable failure with an old */ -/* preconditioner. Retry the step with a new preconditioner. */ - - *jcalc = -1; - goto L300; - } - - if (iernew != 0) { - goto L380; - } - -/* The Newton iteration has converged. If nonnegativity of */ -/* solution is required, set the solution nonnegative, if the */ -/* perturbation to do it is small enough. If the change is too */ -/* large, then consider the corrector iteration to have failed. */ - - if (*nonneg == 0) { - goto L390; - } - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L360: */ -/* Computing MIN */ - d__1 = y[i__]; - delta[i__] = min(d__1,0.); - } - delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); - if (delnrm > *epcon) { - goto L380; - } - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L370: */ - e[i__] -= delta[i__]; - } - goto L390; - - -/* Exits from nonlinear solver. */ -/* No convergence with current preconditioner. */ -/* Compute IERNLS and IDID accordingly. */ - -L380: - if (ires <= -2 || iersl < 0 || iertyp != 0) { - *iernls = -1; - if (ires <= -2) { - *idid = -11; - } - if (iersl < 0) { - *idid = -13; - } - if (iertyp != 0) { - *idid = -15; - } - } else { - *iernls = 1; - if (ires == -1) { - *idid = -10; - } - if (ierpj != 0) { - *idid = -5; - } - if (iersl > 0) { - *idid = -14; - } - } - - -L390: - *jcalc = 1; - return 0; - -/* ------END OF SUBROUTINE DNEDK------------------------------------------ */ -} /* dnedk_ */ - -/* Subroutine */ int dnsk_(doublereal *x, doublereal *y, doublereal *yprime, - integer *neq, S_fp res, U_fp psol, doublereal *wt, doublereal *rpar, - integer *ipar, doublereal *savr, doublereal *delta, doublereal *e, - doublereal *wm, integer *iwm, doublereal *cj, doublereal *sqrtn, - doublereal *rsqrtn, doublereal *eplin, doublereal *epcon, doublereal * - s, doublereal *confac, doublereal *tolnew, integer *muldel, integer * - maxit, integer *ires, integer *iersl, integer *iernew) -{ - /* System generated locals */ - integer i__1; - doublereal d__1, d__2; - - /* Builtin functions */ - double pow_dd(doublereal *, doublereal *); - - /* Local variables */ - integer i__, m; - doublereal rate, rhok; - extern /* Subroutine */ int dslvk_(integer *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, integer *, S_fp, integer *, U_fp, integer *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, integer *); - doublereal delnrm; - extern doublereal ddwnrm_(integer *, doublereal *, doublereal *, - doublereal *, integer *); - doublereal oldnrm; - - -/* ***BEGIN PROLOGUE DNSK */ -/* ***REFER TO DDASPK */ -/* ***DATE WRITTEN 891219 (YYMMDD) */ -/* ***REVISION DATE 900926 (YYMMDD) */ -/* ***REVISION DATE 950126 (YYMMDD) */ -/* ***REVISION DATE 000711 (YYMMDD) */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* DNSK solves a nonlinear system of */ -/* algebraic equations of the form */ -/* G(X,Y,YPRIME) = 0 for the unknown Y. */ - -/* The method used is a modified Newton scheme. */ - -/* The parameters represent */ - -/* X -- Independent variable. */ -/* Y -- Solution vector. */ -/* YPRIME -- Derivative of solution vector. */ -/* NEQ -- Number of unknowns. */ -/* RES -- External user-supplied subroutine */ -/* to evaluate the residual. See RES description */ -/* in DDASPK prologue. */ -/* PSOL -- External user-supplied routine to solve */ -/* a linear system using preconditioning. */ -/* See explanation inside DDASPK. */ -/* WT -- Vector of weights for error criterion. */ -/* RPAR,IPAR -- Real and integer arrays used for communication */ -/* between the calling program and external user */ -/* routines. They are not altered within DASPK. */ -/* SAVR -- Work vector for DNSK of length NEQ. */ -/* DELTA -- Work vector for DNSK of length NEQ. */ -/* E -- Error accumulation vector for DNSK of length NEQ. */ -/* WM,IWM -- Real and integer arrays storing */ -/* matrix information such as the matrix */ -/* of partial derivatives, permutation */ -/* vector, and various other information. */ -/* CJ -- Parameter always proportional to 1/H (step size). */ -/* SQRTN -- Square root of NEQ. */ -/* RSQRTN -- reciprical of square root of NEQ. */ -/* EPLIN -- Tolerance for linear system solver. */ -/* EPCON -- Tolerance to test for convergence of the Newton */ -/* iteration. */ -/* S -- Used for error convergence tests. */ -/* In the Newton iteration: S = RATE/(1.D0-RATE), */ -/* where RATE is the estimated rate of convergence */ -/* of the Newton iteration. */ - -/* The closer RATE is to 0., the faster the Newton */ -/* iteration is converging; the closer RATE is to 1., */ -/* the slower the Newton iteration is converging. */ - -/* The calling routine sends the initial value */ -/* of S to the Newton iteration. */ -/* CONFAC -- A residual scale factor to improve convergence. */ -/* TOLNEW -- Tolerance on the norm of Newton correction in */ -/* alternative Newton convergence test. */ -/* MULDEL -- A flag indicating whether or not to multiply */ -/* DELTA by CONFAC. */ -/* 0 ==> do not scale DELTA by CONFAC. */ -/* 1 ==> scale DELTA by CONFAC. */ -/* MAXIT -- Maximum allowed number of Newton iterations. */ -/* IRES -- Error flag returned from RES. See RES description */ -/* in DDASPK prologue. If IRES = -1, then IERNEW */ -/* will be set to 1. */ -/* If IRES < -1, then IERNEW will be set to -1. */ -/* IERSL -- Error flag for linear system solver. */ -/* See IERSL description in subroutine DSLVK. */ -/* If IERSL = 1, then IERNEW will be set to 1. */ -/* If IERSL < 0, then IERNEW will be set to -1. */ -/* IERNEW -- Error flag for Newton iteration. */ -/* 0 ==> Newton iteration converged. */ -/* 1 ==> recoverable error inside Newton iteration. */ -/* -1 ==> unrecoverable error inside Newton iteration. */ -/* ----------------------------------------------------------------------- */ - -/* ***ROUTINES CALLED */ -/* RES, DSLVK, DDWNRM */ - -/* ***END PROLOGUE DNSK */ - - - - -/* Initialize Newton counter M and accumulation vector E. */ - - /* Parameter adjustments */ - --iwm; - --wm; - --e; - --delta; - --savr; - --ipar; - --rpar; - --wt; - --yprime; - --y; - - /* Function Body */ - m = 0; - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L100: */ - e[i__] = 0.; - } - -/* Corrector loop. */ - -L300: - ++iwm[19]; - -/* If necessary, multiply residual by convergence factor. */ - - if (*muldel == 1) { - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L320: */ - delta[i__] *= *confac; - } - } - -/* Save residual in SAVR. */ - - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L340: */ - savr[i__] = delta[i__]; - } - -/* Compute a new iterate. Store the correction in DELTA. */ - - dslvk_(neq, &y[1], x, &yprime[1], &savr[1], &delta[1], &wt[1], &wm[1], & - iwm[1], (S_fp)res, ires, (U_fp)psol, iersl, cj, eplin, sqrtn, - rsqrtn, &rhok, &rpar[1], &ipar[1]); - if (*ires != 0 || *iersl != 0) { - goto L380; - } - -/* Update Y, E, and YPRIME. */ - - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - y[i__] -= delta[i__]; - e[i__] -= delta[i__]; -/* L360: */ - yprime[i__] -= *cj * delta[i__]; - } - -/* Test for convergence of the iteration. */ - - delnrm = ddwnrm_(neq, &delta[1], &wt[1], &rpar[1], &ipar[1]); - if (m == 0) { - oldnrm = delnrm; - if (delnrm <= *tolnew) { - goto L370; - } - } else { - d__1 = delnrm / oldnrm; - d__2 = 1. / m; - rate = pow_dd(&d__1, &d__2); - if (rate > .9) { - goto L380; - } - *s = rate / (1. - rate); - } - if (*s * delnrm <= *epcon) { - goto L370; - } - -/* The corrector has not yet converged. Update M and test whether */ -/* the maximum number of iterations have been tried. */ - - ++m; - if (m >= *maxit) { - goto L380; - } - -/* Evaluate the residual, and go back to do another iteration. */ - - ++iwm[12]; - (*res)(x, &y[1], &yprime[1], cj, &delta[1], ires, &rpar[1], &ipar[1]); - if (*ires < 0) { - goto L380; - } - goto L300; - -/* The iteration has converged. */ - -L370: - return 0; - -/* The iteration has not converged. Set IERNEW appropriately. */ - -L380: - if (*ires <= -2 || *iersl < 0) { - *iernew = -1; - } else { - *iernew = 1; - } - return 0; - - -/* ------END OF SUBROUTINE DNSK------------------------------------------- */ -} /* dnsk_ */ - -/* Subroutine */ int dslvk_(integer *neq, doublereal *y, doublereal *tn, - doublereal *yprime, doublereal *savr, doublereal *x, doublereal *ewt, - doublereal *wm, integer *iwm, S_fp res, integer *ires, U_fp psol, - integer *iersl, doublereal *cj, doublereal *eplin, doublereal *sqrtn, - doublereal *rsqrtn, doublereal *rhok, doublereal *rpar, integer *ipar) -{ - /* Initialized data */ - - static integer irst = 1; - - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, lq, lr, lv, lz, ldl, nli, nre, kmp, lwk, nps, lwp, ncfl, - lhes, lgmr, maxl, nres, npsl, liwp, iflag; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dcopy_(integer *, doublereal *, integer *, doublereal - *, integer *); - integer miter, nrmax, nrsts, maxlp1; - extern /* Subroutine */ int dspigm_(integer *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, integer * - , integer *, integer *, doublereal *, doublereal *, S_fp, integer - *, integer *, U_fp, integer *, doublereal *, doublereal *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, doublereal *, doublereal *, integer *, integer *, - integer *, doublereal *, integer *); - - -/* ***BEGIN PROLOGUE DSLVK */ -/* ***REFER TO DDASPK */ -/* ***DATE WRITTEN 890101 (YYMMDD) */ -/* ***REVISION DATE 900926 (YYMMDD) */ -/* ***REVISION DATE 940928 Removed MNEWT and added RHOK in call list. */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* DSLVK uses a restart algorithm and interfaces to DSPIGM for */ -/* the solution of the linear system arising from a Newton iteration. */ - -/* In addition to variables described elsewhere, */ -/* communication with DSLVK uses the following variables.. */ -/* WM = Real work space containing data for the algorithm */ -/* (Krylov basis vectors, Hessenberg matrix, etc.). */ -/* IWM = Integer work space containing data for the algorithm. */ -/* X = The right-hand side vector on input, and the solution vector */ -/* on output, of length NEQ. */ -/* IRES = Error flag from RES. */ -/* IERSL = Output flag .. */ -/* IERSL = 0 means no trouble occurred (or user RES routine */ -/* returned IRES < 0) */ -/* IERSL = 1 means the iterative method failed to converge */ -/* (DSPIGM returned IFLAG > 0.) */ -/* IERSL = -1 means there was a nonrecoverable error in the */ -/* iterative solver, and an error exit will occur. */ -/* ----------------------------------------------------------------------- */ -/* ***ROUTINES CALLED */ -/* DSCAL, DCOPY, DSPIGM */ - -/* ***END PROLOGUE DSLVK */ - - - - -/* ----------------------------------------------------------------------- */ -/* IRST is set to 1, to indicate restarting is in effect. */ -/* NRMAX is the maximum number of restarts. */ -/* ----------------------------------------------------------------------- */ - /* Parameter adjustments */ - --ipar; - --rpar; - --iwm; - --wm; - --ewt; - --x; - --savr; - --yprime; - --y; - - /* Function Body */ - - liwp = iwm[30]; - nli = iwm[20]; - nps = iwm[21]; - ncfl = iwm[16]; - nre = iwm[12]; - lwp = iwm[29]; - maxl = iwm[24]; - kmp = iwm[25]; - nrmax = iwm[26]; - miter = iwm[23]; - *iersl = 0; - *ires = 0; -/* ----------------------------------------------------------------------- */ -/* Use a restarting strategy to solve the linear system */ -/* P*X = -F. Parse the work vector, and perform initializations. */ -/* Note that zero is the initial guess for X. */ -/* ----------------------------------------------------------------------- */ - maxlp1 = maxl + 1; - lv = 1; - lr = lv + *neq * maxl; - lhes = lr + *neq + 1; - lq = lhes + maxl * maxlp1; - lwk = lq + (maxl << 1); -/* Computing MIN */ - i__1 = 1, i__2 = maxl - kmp; - ldl = lwk + min(i__1,i__2) * *neq; - lz = ldl + *neq; - dscal_(neq, rsqrtn, &ewt[1], &c__1); - dcopy_(neq, &x[1], &c__1, &wm[lr], &c__1); - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L110: */ - x[i__] = 0.; - } -/* ----------------------------------------------------------------------- */ -/* Top of loop for the restart algorithm. Initial pass approximates */ -/* X and sets up a transformed system to perform subsequent restarts */ -/* to update X. NRSTS is initialized to -1, because restarting */ -/* does not occur until after the first pass. */ -/* Update NRSTS; conditionally copy DL to R; call the DSPIGM */ -/* algorithm to solve A*Z = R; updated counters; update X with */ -/* the residual solution. */ -/* Note: if convergence is not achieved after NRMAX restarts, */ -/* then the linear solver is considered to have failed. */ -/* ----------------------------------------------------------------------- */ - nrsts = -1; -L115: - ++nrsts; - if (nrsts > 0) { - dcopy_(neq, &wm[ldl], &c__1, &wm[lr], &c__1); - } - dspigm_(neq, tn, &y[1], &yprime[1], &savr[1], &wm[lr], &ewt[1], &maxl, & - maxlp1, &kmp, eplin, cj, (S_fp)res, ires, &nres, (U_fp)psol, & - npsl, &wm[lz], &wm[lv], &wm[lhes], &wm[lq], &lgmr, &wm[lwp], &iwm[ - liwp], &wm[lwk], &wm[ldl], rhok, &iflag, &irst, &nrsts, &rpar[1], - &ipar[1]); - nli += lgmr; - nps += npsl; - nre += nres; - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L120: */ - x[i__] += wm[lz + i__ - 1]; - } - if (iflag == 1 && nrsts < nrmax && *ires == 0) { - goto L115; - } -/* ----------------------------------------------------------------------- */ -/* The restart scheme is finished. Test IRES and IFLAG to see if */ -/* convergence was not achieved, and set flags accordingly. */ -/* ----------------------------------------------------------------------- */ - if (*ires < 0) { - ++ncfl; - } else if (iflag != 0) { - ++ncfl; - if (iflag > 0) { - *iersl = 1; - } - if (iflag < 0) { - *iersl = -1; - } - } -/* ----------------------------------------------------------------------- */ -/* Update IWM with counters, rescale EWT, and return. */ -/* ----------------------------------------------------------------------- */ - iwm[20] = nli; - iwm[21] = nps; - iwm[16] = ncfl; - iwm[12] = nre; - dscal_(neq, sqrtn, &ewt[1], &c__1); - return 0; - -/* ------END OF SUBROUTINE DSLVK------------------------------------------ */ -} /* dslvk_ */ - -/* Subroutine */ int dspigm_(integer *neq, doublereal *tn, doublereal *y, - doublereal *yprime, doublereal *savr, doublereal *r__, doublereal * - wght, integer *maxl, integer *maxlp1, integer *kmp, doublereal *eplin, - doublereal *cj, S_fp res, integer *ires, integer *nre, S_fp psol, - integer *npsl, doublereal *z__, doublereal *v, doublereal *hes, - doublereal *q, integer *lgmr, doublereal *wp, integer *iwp, - doublereal *wk, doublereal *dl, doublereal *rhok, integer *iflag, - integer *irst, integer *nrsts, doublereal *rpar, integer *ipar) -{ - /* System generated locals */ - integer v_dim1, v_offset, hes_dim1, hes_offset, i__1, i__2, i__3; - doublereal d__1; - - /* Local variables */ - doublereal c__; - integer i__, j, k; - doublereal s; - integer i2, ll, ip1, ier; - doublereal tem, rho; - integer llp1, info; - extern /* Subroutine */ int datv_(integer *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, S_fp, integer *, S_fp, doublereal *, doublereal *, - doublereal *, integer *, doublereal *, doublereal *, integer *, - integer *, integer *, doublereal *, integer *); - doublereal prod, rnrm; - extern doublereal dnrm2_(integer *, doublereal *, integer *); - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dhels_(doublereal *, integer *, integer *, doublereal - *, doublereal *), dheqr_(doublereal *, integer *, integer *, - doublereal *, integer *, integer *); - doublereal dlnrm; - extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *), dorth_(doublereal *, doublereal *, - doublereal *, integer *, integer *, integer *, integer *, - doublereal *), daxpy_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - integer maxlm1; - doublereal snormw; - - -/* ***BEGIN PROLOGUE DSPIGM */ -/* ***DATE WRITTEN 890101 (YYMMDD) */ -/* ***REVISION DATE 900926 (YYMMDD) */ -/* ***REVISION DATE 940927 Removed MNEWT and added RHOK in call list. */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* This routine solves the linear system A * Z = R using a scaled */ -/* preconditioned version of the generalized minimum residual method. */ -/* An initial guess of Z = 0 is assumed. */ - -/* On entry */ - -/* NEQ = Problem size, passed to PSOL. */ - -/* TN = Current Value of T. */ - -/* Y = Array Containing current dependent variable vector. */ - -/* YPRIME = Array Containing current first derivative of Y. */ - -/* SAVR = Array containing current value of G(T,Y,YPRIME). */ - -/* R = The right hand side of the system A*Z = R. */ -/* R is also used as work space when computing */ -/* the final approximation and will therefore be */ -/* destroyed. */ -/* (R is the same as V(*,MAXL+1) in the call to DSPIGM.) */ - -/* WGHT = The vector of length NEQ containing the nonzero */ -/* elements of the diagonal scaling matrix. */ - -/* MAXL = The maximum allowable order of the matrix H. */ - -/* MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES. */ - -/* KMP = The number of previous vectors the new vector, VNEW, */ -/* must be made orthogonal to. (KMP .LE. MAXL.) */ - -/* EPLIN = Tolerance on residuals R-A*Z in weighted rms norm. */ - -/* CJ = Scalar proportional to current value of */ -/* 1/(step size H). */ - -/* WK = Real work array used by routine DATV and PSOL. */ - -/* DL = Real work array used for calculation of the residual */ -/* norm RHO when the method is incomplete (KMP.LT.MAXL) */ -/* and/or when using restarting. */ - -/* WP = Real work array used by preconditioner PSOL. */ - -/* IWP = Integer work array used by preconditioner PSOL. */ - -/* IRST = Method flag indicating if restarting is being */ -/* performed. IRST .GT. 0 means restarting is active, */ -/* while IRST = 0 means restarting is not being used. */ - -/* NRSTS = Counter for the number of restarts on the current */ -/* call to DSPIGM. If NRSTS .GT. 0, then the residual */ -/* R is already scaled, and so scaling of R is not */ -/* necessary. */ - - -/* On Return */ - -/* Z = The final computed approximation to the solution */ -/* of the system A*Z = R. */ - -/* LGMR = The number of iterations performed and */ -/* the current order of the upper Hessenberg */ -/* matrix HES. */ - -/* NRE = The number of calls to RES (i.e. DATV) */ - -/* NPSL = The number of calls to PSOL. */ - -/* V = The neq by (LGMR+1) array containing the LGMR */ -/* orthogonal vectors V(*,1) to V(*,LGMR). */ - -/* HES = The upper triangular factor of the QR decomposition */ -/* of the (LGMR+1) by LGMR upper Hessenberg matrix whose */ -/* entries are the scaled inner-products of A*V(*,I) */ -/* and V(*,K). */ - -/* Q = Real array of length 2*MAXL containing the components */ -/* of the givens rotations used in the QR decomposition */ -/* of HES. It is loaded in DHEQR and used in DHELS. */ - -/* IRES = Error flag from RES. */ - -/* DL = Scaled preconditioned residual, */ -/* (D-inverse)*(P-inverse)*(R-A*Z). Only loaded when */ -/* performing restarts of the Krylov iteration. */ - -/* RHOK = Weighted norm of final preconditioned residual. */ - -/* IFLAG = Integer error flag.. */ -/* 0 Means convergence in LGMR iterations, LGMR.LE.MAXL. */ -/* 1 Means the convergence test did not pass in MAXL */ -/* iterations, but the new residual norm (RHO) is */ -/* .LT. the old residual norm (RNRM), and so Z is */ -/* computed. */ -/* 2 Means the convergence test did not pass in MAXL */ -/* iterations, new residual norm (RHO) .GE. old residual */ -/* norm (RNRM), and the initial guess, Z = 0, is */ -/* returned. */ -/* 3 Means there was a recoverable error in PSOL */ -/* caused by the preconditioner being out of date. */ -/* -1 Means there was an unrecoverable error in PSOL. */ - -/* ----------------------------------------------------------------------- */ -/* ***ROUTINES CALLED */ -/* PSOL, DNRM2, DSCAL, DATV, DORTH, DHEQR, DCOPY, DHELS, DAXPY */ - -/* ***END PROLOGUE DSPIGM */ - - - /* Parameter adjustments */ - v_dim1 = *neq; - v_offset = 1 + v_dim1; - v -= v_offset; - --y; - --yprime; - --savr; - --r__; - --wght; - hes_dim1 = *maxlp1; - hes_offset = 1 + hes_dim1; - hes -= hes_offset; - --z__; - --q; - --wp; - --iwp; - --wk; - --dl; - --rpar; - --ipar; - - /* Function Body */ - ier = 0; - *iflag = 0; - *lgmr = 0; - *npsl = 0; - *nre = 0; -/* ----------------------------------------------------------------------- */ -/* The initial guess for Z is 0. The initial residual is therefore */ -/* the vector R. Initialize Z to 0. */ -/* ----------------------------------------------------------------------- */ - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L10: */ - z__[i__] = 0.; - } -/* ----------------------------------------------------------------------- */ -/* Apply inverse of left preconditioner to vector R if NRSTS .EQ. 0. */ -/* Form V(*,1), the scaled preconditioned right hand side. */ -/* ----------------------------------------------------------------------- */ - if (*nrsts == 0) { - (*psol)(neq, tn, &y[1], &yprime[1], &savr[1], &wk[1], cj, &wght[1], & - wp[1], &iwp[1], &r__[1], eplin, &ier, &rpar[1], &ipar[1]); - *npsl = 1; - if (ier != 0) { - goto L300; - } - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L30: */ - v[i__ + v_dim1] = r__[i__] * wght[i__]; - } - } else { - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L35: */ - v[i__ + v_dim1] = r__[i__]; - } - } -/* ----------------------------------------------------------------------- */ -/* Calculate norm of scaled vector V(*,1) and normalize it */ -/* If, however, the norm of V(*,1) (i.e. the norm of the preconditioned */ -/* residual) is .le. EPLIN, then return with Z=0. */ -/* ----------------------------------------------------------------------- */ - rnrm = dnrm2_(neq, &v[v_offset], &c__1); - if (rnrm <= *eplin) { - *rhok = rnrm; - return 0; - } - tem = 1. / rnrm; - dscal_(neq, &tem, &v[v_dim1 + 1], &c__1); -/* ----------------------------------------------------------------------- */ -/* Zero out the HES array. */ -/* ----------------------------------------------------------------------- */ - i__1 = *maxl; - for (j = 1; j <= i__1; ++j) { - i__2 = *maxlp1; - for (i__ = 1; i__ <= i__2; ++i__) { -/* L60: */ - hes[i__ + j * hes_dim1] = 0.; - } -/* L65: */ - } -/* ----------------------------------------------------------------------- */ -/* Main loop to compute the vectors V(*,2) to V(*,MAXL). */ -/* The running product PROD is needed for the convergence test. */ -/* ----------------------------------------------------------------------- */ - prod = 1.; - i__1 = *maxl; - for (ll = 1; ll <= i__1; ++ll) { - *lgmr = ll; -/* ----------------------------------------------------------------------- */ -/* Call routine DATV to compute VNEW = ABAR*V(LL), where ABAR is */ -/* the matrix A with scaling and inverse preconditioner factors applied. */ -/* Call routine DORTH to orthogonalize the new vector VNEW = V(*,LL+1). */ -/* call routine DHEQR to update the factors of HES. */ -/* ----------------------------------------------------------------------- */ - datv_(neq, &y[1], tn, &yprime[1], &savr[1], &v[ll * v_dim1 + 1], & - wght[1], &z__[1], (S_fp)res, ires, (S_fp)psol, &v[(ll + 1) * - v_dim1 + 1], &wk[1], &wp[1], &iwp[1], cj, eplin, &ier, nre, - npsl, &rpar[1], &ipar[1]); - if (*ires < 0) { - return 0; - } - if (ier != 0) { - goto L300; - } - dorth_(&v[(ll + 1) * v_dim1 + 1], &v[v_offset], &hes[hes_offset], neq, - &ll, maxlp1, kmp, &snormw); - hes[ll + 1 + ll * hes_dim1] = snormw; - dheqr_(&hes[hes_offset], maxlp1, &ll, &q[1], &info, &ll); - if (info == ll) { - goto L120; - } -/* ----------------------------------------------------------------------- */ -/* Update RHO, the estimate of the norm of the residual R - A*ZL. */ -/* If KMP .LT. MAXL, then the vectors V(*,1),...,V(*,LL+1) are not */ -/* necessarily orthogonal for LL .GT. KMP. The vector DL must then */ -/* be computed, and its norm used in the calculation of RHO. */ -/* ----------------------------------------------------------------------- */ - prod *= q[ll * 2]; - rho = (d__1 = prod * rnrm, abs(d__1)); - if (ll > *kmp && *kmp < *maxl) { - if (ll == *kmp + 1) { - dcopy_(neq, &v[v_dim1 + 1], &c__1, &dl[1], &c__1); - i__2 = *kmp; - for (i__ = 1; i__ <= i__2; ++i__) { - ip1 = i__ + 1; - i2 = i__ << 1; - s = q[i2]; - c__ = q[i2 - 1]; - i__3 = *neq; - for (k = 1; k <= i__3; ++k) { -/* L70: */ - dl[k] = s * dl[k] + c__ * v[k + ip1 * v_dim1]; - } -/* L75: */ - } - } - s = q[ll * 2]; - c__ = q[(ll << 1) - 1] / snormw; - llp1 = ll + 1; - i__2 = *neq; - for (k = 1; k <= i__2; ++k) { -/* L80: */ - dl[k] = s * dl[k] + c__ * v[k + llp1 * v_dim1]; - } - dlnrm = dnrm2_(neq, &dl[1], &c__1); - rho *= dlnrm; - } -/* ----------------------------------------------------------------------- */ -/* Test for convergence. If passed, compute approximation ZL. */ -/* If failed and LL .LT. MAXL, then continue iterating. */ -/* ----------------------------------------------------------------------- */ - if (rho <= *eplin) { - goto L200; - } - if (ll == *maxl) { - goto L100; - } -/* ----------------------------------------------------------------------- */ -/* Rescale so that the norm of V(1,LL+1) is one. */ -/* ----------------------------------------------------------------------- */ - tem = 1. / snormw; - dscal_(neq, &tem, &v[(ll + 1) * v_dim1 + 1], &c__1); -/* L90: */ - } -L100: - if (rho < rnrm) { - goto L150; - } -L120: - *iflag = 2; - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L130: */ - z__[i__] = 0.; - } - return 0; -L150: - *iflag = 1; -/* ----------------------------------------------------------------------- */ -/* The tolerance was not met, but the residual norm was reduced. */ -/* If performing restarting (IRST .gt. 0) calculate the residual vector */ -/* RL and store it in the DL array. If the incomplete version is */ -/* being used (KMP .lt. MAXL) then DL has already been calculated. */ -/* ----------------------------------------------------------------------- */ - if (*irst > 0) { - if (*kmp == *maxl) { - -/* Calculate DL from the V(I)'s. */ - - dcopy_(neq, &v[v_dim1 + 1], &c__1, &dl[1], &c__1); - maxlm1 = *maxl - 1; - i__1 = maxlm1; - for (i__ = 1; i__ <= i__1; ++i__) { - ip1 = i__ + 1; - i2 = i__ << 1; - s = q[i2]; - c__ = q[i2 - 1]; - i__2 = *neq; - for (k = 1; k <= i__2; ++k) { -/* L170: */ - dl[k] = s * dl[k] + c__ * v[k + ip1 * v_dim1]; - } -/* L175: */ - } - s = q[*maxl * 2]; - c__ = q[(*maxl << 1) - 1] / snormw; - i__1 = *neq; - for (k = 1; k <= i__1; ++k) { -/* L180: */ - dl[k] = s * dl[k] + c__ * v[k + *maxlp1 * v_dim1]; - } - } - -/* Scale DL by RNRM*PROD to obtain the residual RL. */ - - tem = rnrm * prod; - dscal_(neq, &tem, &dl[1], &c__1); - } -/* ----------------------------------------------------------------------- */ -/* Compute the approximation ZL to the solution. */ -/* Since the vector Z was used as work space, and the initial guess */ -/* of the Newton correction is zero, Z must be reset to zero. */ -/* ----------------------------------------------------------------------- */ -L200: - ll = *lgmr; - llp1 = ll + 1; - i__1 = llp1; - for (k = 1; k <= i__1; ++k) { -/* L210: */ - r__[k] = 0.; - } - r__[1] = rnrm; - dhels_(&hes[hes_offset], maxlp1, &ll, &q[1], &r__[1]); - i__1 = *neq; - for (k = 1; k <= i__1; ++k) { -/* L220: */ - z__[k] = 0.; - } - i__1 = ll; - for (i__ = 1; i__ <= i__1; ++i__) { - daxpy_(neq, &r__[i__], &v[i__ * v_dim1 + 1], &c__1, &z__[1], &c__1); -/* L230: */ - } - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L240: */ - z__[i__] /= wght[i__]; - } -/* Load RHO into RHOK. */ - *rhok = rho; - return 0; -/* ----------------------------------------------------------------------- */ -/* This block handles error returns forced by routine PSOL. */ -/* ----------------------------------------------------------------------- */ -L300: - if (ier < 0) { - *iflag = -1; - } - if (ier > 0) { - *iflag = 3; - } - - return 0; - -/* ------END OF SUBROUTINE DSPIGM----------------------------------------- */ -} /* dspigm_ */ - -/* Subroutine */ int datv_(integer *neq, doublereal *y, doublereal *tn, - doublereal *yprime, doublereal *savr, doublereal *v, doublereal *wght, - doublereal *yptem, S_fp res, integer *ires, S_fp psol, doublereal * - z__, doublereal *vtem, doublereal *wp, integer *iwp, doublereal *cj, - doublereal *eplin, integer *ier, integer *nre, integer *npsl, - doublereal *rpar, integer *ipar) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__; - - -/* ***BEGIN PROLOGUE DATV */ -/* ***DATE WRITTEN 890101 (YYMMDD) */ -/* ***REVISION DATE 900926 (YYMMDD) */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* This routine computes the product */ - -/* Z = (D-inverse)*(P-inverse)*(dF/dY)*(D*V), */ - -/* where F(Y) = G(T, Y, CJ*(Y-A)), CJ is a scalar proportional to 1/H, */ -/* and A involves the past history of Y. The quantity CJ*(Y-A) is */ -/* an approximation to the first derivative of Y and is stored */ -/* in the array YPRIME. Note that dF/dY = dG/dY + CJ*dG/dYPRIME. */ - -/* D is a diagonal scaling matrix, and P is the left preconditioning */ -/* matrix. V is assumed to have L2 norm equal to 1. */ -/* The product is stored in Z and is computed by means of a */ -/* difference quotient, a call to RES, and one call to PSOL. */ - -/* On entry */ - -/* NEQ = Problem size, passed to RES and PSOL. */ - -/* Y = Array containing current dependent variable vector. */ - -/* YPRIME = Array containing current first derivative of y. */ - -/* SAVR = Array containing current value of G(T,Y,YPRIME). */ - -/* V = Real array of length NEQ (can be the same array as Z). */ - -/* WGHT = Array of length NEQ containing scale factors. */ -/* 1/WGHT(I) are the diagonal elements of the matrix D. */ - -/* YPTEM = Work array of length NEQ. */ - -/* VTEM = Work array of length NEQ used to store the */ -/* unscaled version of V. */ - -/* WP = Real work array used by preconditioner PSOL. */ - -/* IWP = Integer work array used by preconditioner PSOL. */ - -/* CJ = Scalar proportional to current value of */ -/* 1/(step size H). */ - - -/* On return */ - -/* Z = Array of length NEQ containing desired scaled */ -/* matrix-vector product. */ - -/* IRES = Error flag from RES. */ - -/* IER = Error flag from PSOL. */ - -/* NRE = The number of calls to RES. */ - -/* NPSL = The number of calls to PSOL. */ - -/* ----------------------------------------------------------------------- */ -/* ***ROUTINES CALLED */ -/* RES, PSOL */ - -/* ***END PROLOGUE DATV */ - - - /* Parameter adjustments */ - --ipar; - --rpar; - --iwp; - --wp; - --vtem; - --z__; - --yptem; - --wght; - --v; - --savr; - --yprime; - --y; - - /* Function Body */ - *ires = 0; -/* ----------------------------------------------------------------------- */ -/* Set VTEM = D * V. */ -/* ----------------------------------------------------------------------- */ - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L10: */ - vtem[i__] = v[i__] / wght[i__]; - } - *ier = 0; -/* ----------------------------------------------------------------------- */ -/* Store Y in Z and increment Z by VTEM. */ -/* Store YPRIME in YPTEM and increment YPTEM by VTEM*CJ. */ -/* ----------------------------------------------------------------------- */ - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { - yptem[i__] = yprime[i__] + vtem[i__] * *cj; -/* L20: */ - z__[i__] = y[i__] + vtem[i__]; - } -/* ----------------------------------------------------------------------- */ -/* Call RES with incremented Y, YPRIME arguments */ -/* stored in Z, YPTEM. VTEM is overwritten with new residual. */ -/* ----------------------------------------------------------------------- */ - (*res)(tn, &z__[1], &yptem[1], cj, &vtem[1], ires, &rpar[1], &ipar[1]); - ++(*nre); - if (*ires < 0) { - return 0; - } -/* ----------------------------------------------------------------------- */ -/* Set Z = (dF/dY) * VBAR using difference quotient. */ -/* (VBAR is old value of VTEM before calling RES) */ -/* ----------------------------------------------------------------------- */ - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L70: */ - z__[i__] = vtem[i__] - savr[i__]; - } -/* ----------------------------------------------------------------------- */ -/* Apply inverse of left preconditioner to Z. */ -/* ----------------------------------------------------------------------- */ - (*psol)(neq, tn, &y[1], &yprime[1], &savr[1], &yptem[1], cj, &wght[1], & - wp[1], &iwp[1], &z__[1], eplin, ier, &rpar[1], &ipar[1]); - ++(*npsl); - if (*ier != 0) { - return 0; - } -/* ----------------------------------------------------------------------- */ -/* Apply D-inverse to Z and return. */ -/* ----------------------------------------------------------------------- */ - i__1 = *neq; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L90: */ - z__[i__] *= wght[i__]; - } - return 0; - -/* ------END OF SUBROUTINE DATV------------------------------------------- */ -} /* datv_ */ - -/* Subroutine */ int dorth_(doublereal *vnew, doublereal *v, doublereal *hes, - integer *n, integer *ll, integer *ldhes, integer *kmp, doublereal * - snormw) -{ - /* System generated locals */ - integer v_dim1, v_offset, hes_dim1, hes_offset, i__1, i__2; - doublereal d__1, d__2, d__3; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, i0; - doublereal arg, tem; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); - doublereal vnrm; - extern doublereal dnrm2_(integer *, doublereal *, integer *); - extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - doublereal sumdsq; - - -/* ***BEGIN PROLOGUE DORTH */ -/* ***DATE WRITTEN 890101 (YYMMDD) */ -/* ***REVISION DATE 900926 (YYMMDD) */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* This routine orthogonalizes the vector VNEW against the previous */ -/* KMP vectors in the V array. It uses a modified Gram-Schmidt */ -/* orthogonalization procedure with conditional reorthogonalization. */ - -/* On entry */ - -/* VNEW = The vector of length N containing a scaled product */ -/* OF The Jacobian and the vector V(*,LL). */ - -/* V = The N x LL array containing the previous LL */ -/* orthogonal vectors V(*,1) to V(*,LL). */ - -/* HES = An LL x LL upper Hessenberg matrix containing, */ -/* in HES(I,K), K.LT.LL, scaled inner products of */ -/* A*V(*,K) and V(*,I). */ - -/* LDHES = The leading dimension of the HES array. */ - -/* N = The order of the matrix A, and the length of VNEW. */ - -/* LL = The current order of the matrix HES. */ - -/* KMP = The number of previous vectors the new vector VNEW */ -/* must be made orthogonal to (KMP .LE. MAXL). */ - - -/* On return */ - -/* VNEW = The new vector orthogonal to V(*,I0), */ -/* where I0 = MAX(1, LL-KMP+1). */ - -/* HES = Upper Hessenberg matrix with column LL filled in with */ -/* scaled inner products of A*V(*,LL) and V(*,I). */ - -/* SNORMW = L-2 norm of VNEW. */ - -/* ----------------------------------------------------------------------- */ -/* ***ROUTINES CALLED */ -/* DDOT, DNRM2, DAXPY */ - -/* ***END PROLOGUE DORTH */ - - -/* ----------------------------------------------------------------------- */ -/* Get norm of unaltered VNEW for later use. */ -/* ----------------------------------------------------------------------- */ - /* Parameter adjustments */ - --vnew; - v_dim1 = *n; - v_offset = 1 + v_dim1; - v -= v_offset; - hes_dim1 = *ldhes; - hes_offset = 1 + hes_dim1; - hes -= hes_offset; - - /* Function Body */ - vnrm = dnrm2_(n, &vnew[1], &c__1); -/* ----------------------------------------------------------------------- */ -/* Do Modified Gram-Schmidt on VNEW = A*V(LL). */ -/* Scaled inner products give new column of HES. */ -/* Projections of earlier vectors are subtracted from VNEW. */ -/* ----------------------------------------------------------------------- */ -/* Computing MAX */ - i__1 = 1, i__2 = *ll - *kmp + 1; - i0 = max(i__1,i__2); - i__1 = *ll; - for (i__ = i0; i__ <= i__1; ++i__) { - hes[i__ + *ll * hes_dim1] = ddot_(n, &v[i__ * v_dim1 + 1], &c__1, & - vnew[1], &c__1); - tem = -hes[i__ + *ll * hes_dim1]; - daxpy_(n, &tem, &v[i__ * v_dim1 + 1], &c__1, &vnew[1], &c__1); -/* L10: */ - } -/* ----------------------------------------------------------------------- */ -/* Compute SNORMW = norm of VNEW. */ -/* If VNEW is small compared to its input value (in norm), then */ -/* Reorthogonalize VNEW to V(*,1) through V(*,LL). */ -/* Correct if relative correction exceeds 1000*(unit roundoff). */ -/* Finally, correct SNORMW using the dot products involved. */ -/* ----------------------------------------------------------------------- */ - *snormw = dnrm2_(n, &vnew[1], &c__1); - if (vnrm + *snormw * .001 != vnrm) { - return 0; - } - sumdsq = 0.; - i__1 = *ll; - for (i__ = i0; i__ <= i__1; ++i__) { - tem = -ddot_(n, &v[i__ * v_dim1 + 1], &c__1, &vnew[1], &c__1); - if (hes[i__ + *ll * hes_dim1] + tem * .001 == hes[i__ + *ll * - hes_dim1]) { - goto L30; - } - hes[i__ + *ll * hes_dim1] -= tem; - daxpy_(n, &tem, &v[i__ * v_dim1 + 1], &c__1, &vnew[1], &c__1); -/* Computing 2nd power */ - d__1 = tem; - sumdsq += d__1 * d__1; -L30: - ; - } - if (sumdsq == 0.) { - return 0; - } -/* Computing MAX */ -/* Computing 2nd power */ - d__3 = *snormw; - d__1 = 0., d__2 = d__3 * d__3 - sumdsq; - arg = max(d__1,d__2); - *snormw = sqrt(arg); - return 0; - -/* ------END OF SUBROUTINE DORTH------------------------------------------ */ -} /* dorth_ */ - -/* Subroutine */ int dheqr_(doublereal *a, integer *lda, integer *n, - doublereal *q, integer *info, integer *ijob) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - doublereal c__; - integer i__, j, k; - doublereal s, t, t1, t2; - integer iq, km1, kp1, nm1; - - -/* ***BEGIN PROLOGUE DHEQR */ -/* ***DATE WRITTEN 890101 (YYMMDD) */ -/* ***REVISION DATE 900926 (YYMMDD) */ - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* This routine performs a QR decomposition of an upper */ -/* Hessenberg matrix A. There are two options available: */ - -/* (1) performing a fresh decomposition */ -/* (2) updating the QR factors by adding a row and A */ -/* column to the matrix A. */ - -/* DHEQR decomposes an upper Hessenberg matrix by using Givens */ -/* rotations. */ - -/* On entry */ - -/* A DOUBLE PRECISION(LDA, N) */ -/* The matrix to be decomposed. */ - -/* LDA INTEGER */ -/* The leading dimension of the array A. */ - -/* N INTEGER */ -/* A is an (N+1) by N Hessenberg matrix. */ - -/* IJOB INTEGER */ -/* = 1 Means that a fresh decomposition of the */ -/* matrix A is desired. */ -/* .GE. 2 Means that the current decomposition of A */ -/* will be updated by the addition of a row */ -/* and a column. */ -/* On return */ - -/* A The upper triangular matrix R. */ -/* The factorization can be written Q*A = R, where */ -/* Q is a product of Givens rotations and R is upper */ -/* triangular. */ - -/* Q DOUBLE PRECISION(2*N) */ -/* The factors C and S of each Givens rotation used */ -/* in decomposing A. */ - -/* INFO INTEGER */ -/* = 0 normal value. */ -/* = K If A(K,K) .EQ. 0.0. This is not an error */ -/* condition for this subroutine, but it does */ -/* indicate that DHELS will divide by zero */ -/* if called. */ - -/* Modification of LINPACK. */ -/* Peter Brown, Lawrence Livermore Natl. Lab. */ - -/* ----------------------------------------------------------------------- */ -/* ***ROUTINES CALLED (NONE) */ - -/* ***END PROLOGUE DHEQR */ - - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --q; - - /* Function Body */ - if (*ijob > 1) { - goto L70; - } -/* ----------------------------------------------------------------------- */ -/* A new factorization is desired. */ -/* ----------------------------------------------------------------------- */ - -/* QR decomposition without pivoting. */ - - *info = 0; - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - km1 = k - 1; - kp1 = k + 1; - -/* Compute Kth column of R. */ -/* First, multiply the Kth column of A by the previous */ -/* K-1 Givens rotations. */ - - if (km1 < 1) { - goto L20; - } - i__2 = km1; - for (j = 1; j <= i__2; ++j) { - i__ = ((j - 1) << 1) + 1; - t1 = a[j + k * a_dim1]; - t2 = a[j + 1 + k * a_dim1]; - c__ = q[i__]; - s = q[i__ + 1]; - a[j + k * a_dim1] = c__ * t1 - s * t2; - a[j + 1 + k * a_dim1] = s * t1 + c__ * t2; -/* L10: */ - } - -/* Compute Givens components C and S. */ - -L20: - iq = (km1 << 1) + 1; - t1 = a[k + k * a_dim1]; - t2 = a[kp1 + k * a_dim1]; - if (t2 != 0.) { - goto L30; - } - c__ = 1.; - s = 0.; - goto L50; -L30: - if (abs(t2) < abs(t1)) { - goto L40; - } - t = t1 / t2; - s = -1. / sqrt(t * t + 1.); - c__ = -s * t; - goto L50; -L40: - t = t2 / t1; - c__ = 1. / sqrt(t * t + 1.); - s = -c__ * t; -L50: - q[iq] = c__; - q[iq + 1] = s; - a[k + k * a_dim1] = c__ * t1 - s * t2; - if (a[k + k * a_dim1] == 0.) { - *info = k; - } -/* L60: */ - } - return 0; -/* ----------------------------------------------------------------------- */ -/* The old factorization of A will be updated. A row and a column */ -/* has been added to the matrix A. */ -/* N by N-1 is now the old size of the matrix. */ -/* ----------------------------------------------------------------------- */ -L70: - nm1 = *n - 1; -/* ----------------------------------------------------------------------- */ -/* Multiply the new column by the N previous Givens rotations. */ -/* ----------------------------------------------------------------------- */ - i__1 = nm1; - for (k = 1; k <= i__1; ++k) { - i__ = ((k - 1) << 1) + 1; - t1 = a[k + *n * a_dim1]; - t2 = a[k + 1 + *n * a_dim1]; - c__ = q[i__]; - s = q[i__ + 1]; - a[k + *n * a_dim1] = c__ * t1 - s * t2; - a[k + 1 + *n * a_dim1] = s * t1 + c__ * t2; -/* L100: */ - } -/* ----------------------------------------------------------------------- */ -/* Complete update of decomposition by forming last Givens rotation, */ -/* and multiplying it times the column vector (A(N,N),A(NP1,N)). */ -/* ----------------------------------------------------------------------- */ - *info = 0; - t1 = a[*n + *n * a_dim1]; - t2 = a[*n + 1 + *n * a_dim1]; - if (t2 != 0.) { - goto L110; - } - c__ = 1.; - s = 0.; - goto L130; -L110: - if (abs(t2) < abs(t1)) { - goto L120; - } - t = t1 / t2; - s = -1. / sqrt(t * t + 1.); - c__ = -s * t; - goto L130; -L120: - t = t2 / t1; - c__ = 1. / sqrt(t * t + 1.); - s = -c__ * t; -L130: - iq = (*n << 1) - 1; - q[iq] = c__; - q[iq + 1] = s; - a[*n + *n * a_dim1] = c__ * t1 - s * t2; - if (a[*n + *n * a_dim1] == 0.) { - *info = *n; - } - return 0; - -/* ------END OF SUBROUTINE DHEQR------------------------------------------ */ -} /* dheqr_ */ - -/* Subroutine */ int dhels_(doublereal *a, integer *lda, integer *n, - doublereal *q, doublereal *b) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - doublereal c__; - integer k; - doublereal s, t, t1, t2; - integer kb, iq, kp1; - extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - - -/* ***BEGIN PROLOGUE DHELS */ -/* ***DATE WRITTEN 890101 (YYMMDD) */ -/* ***REVISION DATE 900926 (YYMMDD) */ - - -/* ----------------------------------------------------------------------- */ -/* ***DESCRIPTION */ - -/* This is similar to the LINPACK routine DGESL except that */ -/* A is an upper Hessenberg matrix. */ - -/* DHELS solves the least squares problem */ - -/* MIN (B-A*X,B-A*X) */ - -/* using the factors computed by DHEQR. */ - -/* On entry */ - -/* A DOUBLE PRECISION (LDA, N) */ -/* The output from DHEQR which contains the upper */ -/* triangular factor R in the QR decomposition of A. */ - -/* LDA INTEGER */ -/* The leading dimension of the array A . */ - -/* N INTEGER */ -/* A is originally an (N+1) by N matrix. */ - -/* Q DOUBLE PRECISION(2*N) */ -/* The coefficients of the N givens rotations */ -/* used in the QR factorization of A. */ - -/* B DOUBLE PRECISION(N+1) */ -/* The right hand side vector. */ - - -/* On return */ - -/* B The solution vector X. */ - - -/* Modification of LINPACK. */ -/* Peter Brown, Lawrence Livermore Natl. Lab. */ - -/* ----------------------------------------------------------------------- */ -/* ***ROUTINES CALLED */ -/* DAXPY */ - -/* ***END PROLOGUE DHELS */ - - -/* Minimize (B-A*X,B-A*X). */ -/* First form Q*B. */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --q; - --b; - - /* Function Body */ - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - kp1 = k + 1; - iq = ((k - 1) << 1) + 1; - c__ = q[iq]; - s = q[iq + 1]; - t1 = b[k]; - t2 = b[kp1]; - b[k] = c__ * t1 - s * t2; - b[kp1] = s * t1 + c__ * t2; -/* L20: */ - } - -/* Now solve R*X = Q*B. */ - - i__1 = *n; - for (kb = 1; kb <= i__1; ++kb) { - k = *n + 1 - kb; - b[k] /= a[k + k * a_dim1]; - t = -b[k]; - i__2 = k - 1; - daxpy_(&i__2, &t, &a[k * a_dim1 + 1], &c__1, &b[1], &c__1); -/* L40: */ - } - return 0; - -/* ------END OF SUBROUTINE DHELS------------------------------------------ */ -} /* dhels_ */ - diff --git a/ext/f2c_math/dgbefa.c b/ext/f2c_math/dgbefa.c deleted file mode 100644 index f98c570b9..000000000 --- a/ext/f2c_math/dgbefa.c +++ /dev/null @@ -1,240 +0,0 @@ -/* dgbefa.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dgbfa_(doublereal *abd, integer *lda, integer *n, - integer *ml, integer *mu, integer *ipvt, integer *info) -{ - /* System generated locals */ - integer abd_dim1, abd_offset, i__1, i__2, i__3, i__4; - - /* Local variables */ - integer i__, j, k, l, m; - doublereal t; - integer i0, j0, j1, lm, mm, ju, jz, kp1, nm1; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), daxpy_(integer *, doublereal *, doublereal *, integer - *, doublereal *, integer *); - extern integer idamax_(integer *, doublereal *, integer *); - - -/* dgbfa factors a double precision band matrix by elimination. */ - -/* dgbfa is usually called by dgbco, but it can be called */ -/* directly with a saving in time if rcond is not needed. */ - -/* on entry */ - -/* abd double precision(lda, n) */ -/* contains the matrix in band storage. the columns */ -/* of the matrix are stored in the columns of abd and */ -/* the diagonals of the matrix are stored in rows */ -/* ml+1 through 2*ml+mu+1 of abd . */ -/* see the comments below for details. */ - -/* lda integer */ -/* the leading dimension of the array abd . */ -/* lda must be .ge. 2*ml + mu + 1 . */ - -/* n integer */ -/* the order of the original matrix. */ - -/* ml integer */ -/* number of diagonals below the main diagonal. */ -/* 0 .le. ml .lt. n . */ - -/* mu integer */ -/* number of diagonals above the main diagonal. */ -/* 0 .le. mu .lt. n . */ -/* more efficient if ml .le. mu . */ -/* on return */ - -/* abd an upper triangular matrix in band storage and */ -/* the multipliers which were used to obtain it. */ -/* the factorization can be written a = l*u where */ -/* l is a product of permutation and unit lower */ -/* triangular matrices and u is upper triangular. */ - -/* ipvt integer(n) */ -/* an integer vector of pivot indices. */ - -/* info integer */ -/* = 0 normal value. */ -/* = k if u(k,k) .eq. 0.0 . this is not an error */ -/* condition for this subroutine, but it does */ -/* indicate that dgbsl will divide by zero if */ -/* called. use rcond in dgbco for a reliable */ -/* indication of singularity. */ - -/* band storage */ - -/* if a is a band matrix, the following program segment */ -/* will set up the input. */ - -/* ml = (band width below the diagonal) */ -/* mu = (band width above the diagonal) */ -/* m = ml + mu + 1 */ -/* do 20 j = 1, n */ -/* i1 = max0(1, j-mu) */ -/* i2 = min0(n, j+ml) */ -/* do 10 i = i1, i2 */ -/* k = i - j + m */ -/* abd(k,j) = a(i,j) */ -/* 10 continue */ -/* 20 continue */ - -/* this uses rows ml+1 through 2*ml+mu+1 of abd . */ -/* in addition, the first ml rows in abd are used for */ -/* elements generated during the triangularization. */ -/* the total number of rows needed in abd is 2*ml+mu+1 . */ -/* the ml+mu by ml+mu upper left triangle and the */ -/* ml by ml lower right triangle are not referenced. */ - -/* linpack. this version dated 08/14/78 . */ -/* cleve moler, university of new mexico, argonne national lab. */ - -/* subroutines and functions */ - -/* blas daxpy,dscal,idamax */ -/* fortran max0,min0 */ - -/* internal variables */ - - - - /* Parameter adjustments */ - abd_dim1 = *lda; - abd_offset = 1 + abd_dim1; - abd -= abd_offset; - --ipvt; - - /* Function Body */ - m = *ml + *mu + 1; - *info = 0; - -/* zero initial fill-in columns */ - - j0 = *mu + 2; - j1 = min(*n,m) - 1; - if (j1 < j0) { - goto L30; - } - i__1 = j1; - for (jz = j0; jz <= i__1; ++jz) { - i0 = m + 1 - jz; - i__2 = *ml; - for (i__ = i0; i__ <= i__2; ++i__) { - abd[i__ + jz * abd_dim1] = 0.; -/* L10: */ - } -/* L20: */ - } -L30: - jz = j1; - ju = 0; - -/* gaussian elimination with partial pivoting */ - - nm1 = *n - 1; - if (nm1 < 1) { - goto L130; - } - i__1 = nm1; - for (k = 1; k <= i__1; ++k) { - kp1 = k + 1; - -/* zero next fill-in column */ - - ++jz; - if (jz > *n) { - goto L50; - } - if (*ml < 1) { - goto L50; - } - i__2 = *ml; - for (i__ = 1; i__ <= i__2; ++i__) { - abd[i__ + jz * abd_dim1] = 0.; -/* L40: */ - } -L50: - -/* find l = pivot index */ - -/* Computing MIN */ - i__2 = *ml, i__3 = *n - k; - lm = min(i__2,i__3); - i__2 = lm + 1; - l = idamax_(&i__2, &abd[m + k * abd_dim1], &c__1) + m - 1; - ipvt[k] = l + k - m; - -/* zero pivot implies this column already triangularized */ - - if (abd[l + k * abd_dim1] == 0.) { - goto L100; - } - -/* interchange if necessary */ - - if (l == m) { - goto L60; - } - t = abd[l + k * abd_dim1]; - abd[l + k * abd_dim1] = abd[m + k * abd_dim1]; - abd[m + k * abd_dim1] = t; -L60: - -/* compute multipliers */ - - t = -1. / abd[m + k * abd_dim1]; - dscal_(&lm, &t, &abd[m + 1 + k * abd_dim1], &c__1); - -/* row elimination with column indexing */ - -/* Computing MIN */ -/* Computing MAX */ - i__3 = ju, i__4 = *mu + ipvt[k]; - i__2 = max(i__3,i__4); - ju = min(i__2,*n); - mm = m; - if (ju < kp1) { - goto L90; - } - i__2 = ju; - for (j = kp1; j <= i__2; ++j) { - --l; - --mm; - t = abd[l + j * abd_dim1]; - if (l == mm) { - goto L70; - } - abd[l + j * abd_dim1] = abd[mm + j * abd_dim1]; - abd[mm + j * abd_dim1] = t; -L70: - daxpy_(&lm, &t, &abd[m + 1 + k * abd_dim1], &c__1, &abd[mm + 1 + - j * abd_dim1], &c__1); -/* L80: */ - } -L90: - goto L110; -L100: - *info = k; -L110: -/* L120: */ - ; - } -L130: - ipvt[*n] = *n; - if (abd[m + *n * abd_dim1] == 0.) { - *info = *n; - } - return 0; -} /* dgbfa_ */ - diff --git a/ext/f2c_math/dgbsl.c b/ext/f2c_math/dgbsl.c deleted file mode 100644 index bcafc9fb8..000000000 --- a/ext/f2c_math/dgbsl.c +++ /dev/null @@ -1,193 +0,0 @@ -/* dgbsl.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dgbsl_(doublereal *abd, integer *lda, integer *n, - integer *ml, integer *mu, integer *ipvt, doublereal *b, integer *job) -{ - /* System generated locals */ - integer abd_dim1, abd_offset, i__1, i__2, i__3; - - /* Local variables */ - integer k, l, m; - doublereal t; - integer kb, la, lb, lm, nm1; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); - extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - - -/* dgbsl solves the double precision band system */ -/* a * x = b or trans(a) * x = b */ -/* using the factors computed by dgbco or dgbfa. */ - -/* on entry */ - -/* abd double precision(lda, n) */ -/* the output from dgbco or dgbfa. */ - -/* lda integer */ -/* the leading dimension of the array abd . */ - -/* n integer */ -/* the order of the original matrix. */ - -/* ml integer */ -/* number of diagonals below the main diagonal. */ - -/* mu integer */ -/* number of diagonals above the main diagonal. */ - -/* ipvt integer(n) */ -/* the pivot vector from dgbco or dgbfa. */ - -/* b double precision(n) */ -/* the right hand side vector. */ - -/* job integer */ -/* = 0 to solve a*x = b , */ -/* = nonzero to solve trans(a)*x = b , where */ -/* trans(a) is the transpose. */ - -/* on return */ - -/* b the solution vector x . */ - -/* error condition */ - -/* a division by zero will occur if the input factor contains a */ -/* zero on the diagonal. technically this indicates singularity */ -/* but it is often caused by improper arguments or improper */ -/* setting of lda . it will not occur if the subroutines are */ -/* called correctly and if dgbco has set rcond .gt. 0.0 */ -/* or dgbfa has set info .eq. 0 . */ - -/* to compute inverse(a) * c where c is a matrix */ -/* with p columns */ -/* call dgbco(abd,lda,n,ml,mu,ipvt,rcond,z) */ -/* if (rcond is too small) go to ... */ -/* do 10 j = 1, p */ -/* call dgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0) */ -/* 10 continue */ - -/* linpack. this version dated 08/14/78 . */ -/* cleve moler, university of new mexico, argonne national lab. */ - -/* subroutines and functions */ - -/* blas daxpy,ddot */ -/* fortran min0 */ - -/* internal variables */ - - - /* Parameter adjustments */ - abd_dim1 = *lda; - abd_offset = 1 + abd_dim1; - abd -= abd_offset; - --ipvt; - --b; - - /* Function Body */ - m = *mu + *ml + 1; - nm1 = *n - 1; - if (*job != 0) { - goto L50; - } - -/* job = 0 , solve a * x = b */ -/* first solve l*y = b */ - - if (*ml == 0) { - goto L30; - } - if (nm1 < 1) { - goto L30; - } - i__1 = nm1; - for (k = 1; k <= i__1; ++k) { -/* Computing MIN */ - i__2 = *ml, i__3 = *n - k; - lm = min(i__2,i__3); - l = ipvt[k]; - t = b[l]; - if (l == k) { - goto L10; - } - b[l] = b[k]; - b[k] = t; -L10: - daxpy_(&lm, &t, &abd[m + 1 + k * abd_dim1], &c__1, &b[k + 1], &c__1); -/* L20: */ - } -L30: - -/* now solve u*x = y */ - - i__1 = *n; - for (kb = 1; kb <= i__1; ++kb) { - k = *n + 1 - kb; - b[k] /= abd[m + k * abd_dim1]; - lm = min(k,m) - 1; - la = m - lm; - lb = k - lm; - t = -b[k]; - daxpy_(&lm, &t, &abd[la + k * abd_dim1], &c__1, &b[lb], &c__1); -/* L40: */ - } - goto L100; -L50: - -/* job = nonzero, solve trans(a) * x = b */ -/* first solve trans(u)*y = b */ - - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - lm = min(k,m) - 1; - la = m - lm; - lb = k - lm; - t = ddot_(&lm, &abd[la + k * abd_dim1], &c__1, &b[lb], &c__1); - b[k] = (b[k] - t) / abd[m + k * abd_dim1]; -/* L60: */ - } - -/* now solve trans(l)*x = y */ - - if (*ml == 0) { - goto L90; - } - if (nm1 < 1) { - goto L90; - } - i__1 = nm1; - for (kb = 1; kb <= i__1; ++kb) { - k = *n - kb; -/* Computing MIN */ - i__2 = *ml, i__3 = *n - k; - lm = min(i__2,i__3); - b[k] += ddot_(&lm, &abd[m + 1 + k * abd_dim1], &c__1, &b[k + 1], & - c__1); - l = ipvt[k]; - if (l == k) { - goto L70; - } - t = b[l]; - b[l] = b[k]; - b[k] = t; -L70: -/* L80: */ - ; - } -L90: -L100: - return 0; -} /* dgbsl_ */ - diff --git a/ext/f2c_math/dgefa.c b/ext/f2c_math/dgefa.c deleted file mode 100644 index 42e9094a5..000000000 --- a/ext/f2c_math/dgefa.c +++ /dev/null @@ -1,151 +0,0 @@ -/* dgefa.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dgefa_(doublereal *a, integer *lda, integer *n, integer * - ipvt, integer *info) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - - /* Local variables */ - integer j, k, l; - doublereal t; - integer kp1, nm1; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), daxpy_(integer *, doublereal *, doublereal *, integer - *, doublereal *, integer *); - extern integer idamax_(integer *, doublereal *, integer *); - - -/* dgefa factors a double precision matrix by gaussian elimination. */ - -/* dgefa is usually called by dgeco, but it can be called */ -/* directly with a saving in time if rcond is not needed. */ -/* (time for dgeco) = (1 + 9/n)*(time for dgefa) . */ - -/* on entry */ - -/* a double precision(lda, n) */ -/* the matrix to be factored. */ - -/* lda integer */ -/* the leading dimension of the array a . */ - -/* n integer */ -/* the order of the matrix a . */ - -/* on return */ - -/* a an upper triangular matrix and the multipliers */ -/* which were used to obtain it. */ -/* the factorization can be written a = l*u where */ -/* l is a product of permutation and unit lower */ -/* triangular matrices and u is upper triangular. */ - -/* ipvt integer(n) */ -/* an integer vector of pivot indices. */ - -/* info integer */ -/* = 0 normal value. */ -/* = k if u(k,k) .eq. 0.0 . this is not an error */ -/* condition for this subroutine, but it does */ -/* indicate that dgesl or dgedi will divide by zero */ -/* if called. use rcond in dgeco for a reliable */ -/* indication of singularity. */ - -/* linpack. this version dated 08/14/78 . */ -/* cleve moler, university of new mexico, argonne national lab. */ - -/* subroutines and functions */ - -/* blas daxpy,dscal,idamax */ - -/* internal variables */ - - - -/* gaussian elimination with partial pivoting */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipvt; - - /* Function Body */ - *info = 0; - nm1 = *n - 1; - if (nm1 < 1) { - goto L70; - } - i__1 = nm1; - for (k = 1; k <= i__1; ++k) { - kp1 = k + 1; - -/* find l = pivot index */ - - i__2 = *n - k + 1; - l = idamax_(&i__2, &a[k + k * a_dim1], &c__1) + k - 1; - ipvt[k] = l; - -/* zero pivot implies this column already triangularized */ - - if (a[l + k * a_dim1] == 0.) { - goto L40; - } - -/* interchange if necessary */ - - if (l == k) { - goto L10; - } - t = a[l + k * a_dim1]; - a[l + k * a_dim1] = a[k + k * a_dim1]; - a[k + k * a_dim1] = t; -L10: - -/* compute multipliers */ - - t = -1. / a[k + k * a_dim1]; - i__2 = *n - k; - dscal_(&i__2, &t, &a[k + 1 + k * a_dim1], &c__1); - -/* row elimination with column indexing */ - - i__2 = *n; - for (j = kp1; j <= i__2; ++j) { - t = a[l + j * a_dim1]; - if (l == k) { - goto L20; - } - a[l + j * a_dim1] = a[k + j * a_dim1]; - a[k + j * a_dim1] = t; -L20: - i__3 = *n - k; - daxpy_(&i__3, &t, &a[k + 1 + k * a_dim1], &c__1, &a[k + 1 + j * - a_dim1], &c__1); -/* L30: */ - } - goto L50; -L40: - *info = k; -L50: -/* L60: */ - ; - } -L70: - ipvt[*n] = *n; - if (a[*n + *n * a_dim1] == 0.) { - *info = *n; - } - return 0; -} /* dgefa_ */ - diff --git a/ext/f2c_math/dgesl.c b/ext/f2c_math/dgesl.c deleted file mode 100644 index 8f3a43e92..000000000 --- a/ext/f2c_math/dgesl.c +++ /dev/null @@ -1,170 +0,0 @@ -/* dgesl.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* Subroutine */ int dgesl_(doublereal *a, integer *lda, integer *n, integer * - ipvt, doublereal *b, integer *job) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer k, l; - doublereal t; - integer kb, nm1; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); - extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - - -/* dgesl solves the double precision system */ -/* a * x = b or trans(a) * x = b */ -/* using the factors computed by dgeco or dgefa. */ - -/* on entry */ - -/* a double precision(lda, n) */ -/* the output from dgeco or dgefa. */ - -/* lda integer */ -/* the leading dimension of the array a . */ - -/* n integer */ -/* the order of the matrix a . */ - -/* ipvt integer(n) */ -/* the pivot vector from dgeco or dgefa. */ - -/* b double precision(n) */ -/* the right hand side vector. */ - -/* job integer */ -/* = 0 to solve a*x = b , */ -/* = nonzero to solve trans(a)*x = b where */ -/* trans(a) is the transpose. */ - -/* on return */ - -/* b the solution vector x . */ - -/* error condition */ - -/* a division by zero will occur if the input factor contains a */ -/* zero on the diagonal. technically this indicates singularity */ -/* but it is often caused by improper arguments or improper */ -/* setting of lda . it will not occur if the subroutines are */ -/* called correctly and if dgeco has set rcond .gt. 0.0 */ -/* or dgefa has set info .eq. 0 . */ - -/* to compute inverse(a) * c where c is a matrix */ -/* with p columns */ -/* call dgeco(a,lda,n,ipvt,rcond,z) */ -/* if (rcond is too small) go to ... */ -/* do 10 j = 1, p */ -/* call dgesl(a,lda,n,ipvt,c(1,j),0) */ -/* 10 continue */ - -/* linpack. this version dated 08/14/78 . */ -/* cleve moler, university of new mexico, argonne national lab. */ - -/* subroutines and functions */ - -/* blas daxpy,ddot */ - -/* internal variables */ - - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipvt; - --b; - - /* Function Body */ - nm1 = *n - 1; - if (*job != 0) { - goto L50; - } - -/* job = 0 , solve a * x = b */ -/* first solve l*y = b */ - - if (nm1 < 1) { - goto L30; - } - i__1 = nm1; - for (k = 1; k <= i__1; ++k) { - l = ipvt[k]; - t = b[l]; - if (l == k) { - goto L10; - } - b[l] = b[k]; - b[k] = t; -L10: - i__2 = *n - k; - daxpy_(&i__2, &t, &a[k + 1 + k * a_dim1], &c__1, &b[k + 1], &c__1); -/* L20: */ - } -L30: - -/* now solve u*x = y */ - - i__1 = *n; - for (kb = 1; kb <= i__1; ++kb) { - k = *n + 1 - kb; - b[k] /= a[k + k * a_dim1]; - t = -b[k]; - i__2 = k - 1; - daxpy_(&i__2, &t, &a[k * a_dim1 + 1], &c__1, &b[1], &c__1); -/* L40: */ - } - goto L100; -L50: - -/* job = nonzero, solve trans(a) * x = b */ -/* first solve trans(u)*y = b */ - - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - i__2 = k - 1; - t = ddot_(&i__2, &a[k * a_dim1 + 1], &c__1, &b[1], &c__1); - b[k] = (b[k] - t) / a[k + k * a_dim1]; -/* L60: */ - } - -/* now solve trans(l)*x = y */ - - if (nm1 < 1) { - goto L90; - } - i__1 = nm1; - for (kb = 1; kb <= i__1; ++kb) { - k = *n - kb; - i__2 = *n - k; - b[k] += ddot_(&i__2, &a[k + 1 + k * a_dim1], &c__1, &b[k + 1], &c__1); - l = ipvt[k]; - if (l == k) { - goto L70; - } - t = b[l]; - b[l] = b[k]; - b[k] = t; -L70: -/* L80: */ - ; - } -L90: -L100: - return 0; -} /* dgesl_ */ - diff --git a/ext/f2c_math/dp1vlu.c b/ext/f2c_math/dp1vlu.c deleted file mode 100644 index 894219901..000000000 --- a/ext/f2c_math/dp1vlu.c +++ /dev/null @@ -1,248 +0,0 @@ -/* dp1vlu.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static integer c__8 = 8; -static integer c__2 = 2; -static integer c__5 = 5; - -/* DECK DP1VLU */ -/* Subroutine */ int dp1vlu_(integer *l, integer *nder, doublereal *x, - doublereal *yfit, doublereal *yp, doublereal *a) -{ - /* System generated locals */ - address a__1[5]; - integer i__1, i__2, i__3[5]; - char ch__1[150]; - icilist ici__1; - - /* Builtin functions */ - integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void) - ; - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - integer i__, n, k1, k2, k3, k4; - doublereal cc; - integer ic, kc, in, k1i, lm1, lp1; - doublereal dif; - integer k3p1, k4p1, ndo; - doublereal val; - integer ilo, iup, ndp1, inp1, k3pn, k4pn, nord; - char xern1[8], xern2[8]; - integer maxord; - extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *, - integer *, ftnlen, ftnlen, ftnlen); - -/* ***BEGIN PROLOGUE DP1VLU */ -/* ***PURPOSE Use the coefficients generated by DPOLFT to evaluate the */ -/* polynomial fit of degree L, along with the first NDER of */ -/* its derivatives, at a specified point. */ -/* ***LIBRARY SLATEC */ -/* ***CATEGORY K6 */ -/* ***TYPE DOUBLE PRECISION (PVALUE-S, DP1VLU-D) */ -/* ***KEYWORDS CURVE FITTING, LEAST SQUARES, POLYNOMIAL APPROXIMATION */ -/* ***AUTHOR Shampine, L. F., (SNLA) */ -/* Davenport, S. M., (SNLA) */ -/* ***DESCRIPTION */ - -/* Abstract */ - -/* The subroutine DP1VLU uses the coefficients generated by DPOLFT */ -/* to evaluate the polynomial fit of degree L , along with the first */ -/* NDER of its derivatives, at a specified point. Computationally */ -/* stable recurrence relations are used to perform this task. */ - -/* The parameters for DP1VLU are */ - -/* Input -- ALL TYPE REAL variables are DOUBLE PRECISION */ -/* L - the degree of polynomial to be evaluated. L may be */ -/* any non-negative integer which is less than or equal */ -/* to NDEG , the highest degree polynomial provided */ -/* by DPOLFT . */ -/* NDER - the number of derivatives to be evaluated. NDER */ -/* may be 0 or any positive value. If NDER is less */ -/* than 0, it will be treated as 0. */ -/* X - the argument at which the polynomial and its */ -/* derivatives are to be evaluated. */ -/* A - work and output array containing values from last */ -/* call to DPOLFT . */ - -/* Output -- ALL TYPE REAL variables are DOUBLE PRECISION */ -/* YFIT - value of the fitting polynomial of degree L at X */ -/* YP - array containing the first through NDER derivatives */ -/* of the polynomial of degree L . YP must be */ -/* dimensioned at least NDER in the calling program. */ - -/* ***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, */ -/* Curve fitting by polynomials in one variable, Report */ -/* SLA-74-0270, Sandia Laboratories, June 1974. */ -/* ***ROUTINES CALLED XERMSG */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 740601 DATE WRITTEN */ -/* 890531 Changed all specific intrinsics to generic. (WRB) */ -/* 890911 Removed unnecessary intrinsics. (WRB) */ -/* 891006 Cosmetic changes to prologue. (WRB) */ -/* 891006 REVISION DATE from Version 3.2 */ -/* 891214 Prologue converted to Version 4.0 format. (BAB) */ -/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */ -/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */ -/* 920501 Reformatted the REFERENCES section. (WRB) */ -/* ***END PROLOGUE DP1VLU */ -/* ***FIRST EXECUTABLE STATEMENT DP1VLU */ - /* Parameter adjustments */ - --a; - --yp; - - /* Function Body */ - if (*l < 0) { - goto L12; - } - ndo = max(*nder,0); - ndo = min(ndo,*l); - maxord = (integer) (a[1] + .5); - k1 = maxord + 1; - k2 = k1 + maxord; - k3 = k2 + maxord + 2; - nord = (integer) (a[k3] + .5); - if (*l > nord) { - goto L11; - } - k4 = k3 + *l + 1; - if (*nder < 1) { - goto L2; - } - i__1 = *nder; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L1: */ - yp[i__] = 0.; - } -L2: - if (*l >= 2) { - goto L4; - } - if (*l == 1) { - goto L3; - } - -/* L IS 0 */ - - val = a[k2 + 1]; - goto L10; - -/* L IS 1 */ - -L3: - cc = a[k2 + 2]; - val = a[k2 + 1] + (*x - a[2]) * cc; - if (*nder >= 1) { - yp[1] = cc; - } - goto L10; - -/* L IS GREATER THAN 1 */ - -L4: - ndp1 = ndo + 1; - k3p1 = k3 + 1; - k4p1 = k4 + 1; - lp1 = *l + 1; - lm1 = *l - 1; - ilo = k3 + 3; - iup = k4 + ndp1; - i__1 = iup; - for (i__ = ilo; i__ <= i__1; ++i__) { -/* L5: */ - a[i__] = 0.; - } - dif = *x - a[lp1]; - kc = k2 + lp1; - a[k4p1] = a[kc]; - a[k3p1] = a[kc - 1] + dif * a[k4p1]; - a[k3 + 2] = a[k4p1]; - -/* EVALUATE RECURRENCE RELATIONS FOR FUNCTION VALUE AND DERIVATIVES */ - - i__1 = lm1; - for (i__ = 1; i__ <= i__1; ++i__) { - in = *l - i__; - inp1 = in + 1; - k1i = k1 + inp1; - ic = k2 + in; - dif = *x - a[inp1]; - val = a[ic] + dif * a[k3p1] - a[k1i] * a[k4p1]; - if (ndo <= 0) { - goto L8; - } - i__2 = ndo; - for (n = 1; n <= i__2; ++n) { - k3pn = k3p1 + n; - k4pn = k4p1 + n; -/* L6: */ - yp[n] = dif * a[k3pn] + n * a[k3pn - 1] - a[k1i] * a[k4pn]; - } - -/* SAVE VALUES NEEDED FOR NEXT EVALUATION OF RECURRENCE RELATIONS */ - - i__2 = ndo; - for (n = 1; n <= i__2; ++n) { - k3pn = k3p1 + n; - k4pn = k4p1 + n; - a[k4pn] = a[k3pn]; -/* L7: */ - a[k3pn] = yp[n]; - } -L8: - a[k4p1] = a[k3p1]; -/* L9: */ - a[k3p1] = val; - } - -/* NORMAL RETURN OR ABORT DUE TO ERROR */ - -L10: - *yfit = val; - return 0; - -L11: - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = 8; - ici__1.iciunit = xern1; - ici__1.icifmt = "(I8)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&(*l), (ftnlen)sizeof(integer)); - e_wsfi(); - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = 8; - ici__1.iciunit = xern2; - ici__1.icifmt = "(I8)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&nord, (ftnlen)sizeof(integer)); - e_wsfi(); -/* Writing concatenation */ - i__3[0] = 40, a__1[0] = "THE ORDER OF POLYNOMIAL EVALUATION, L = "; - i__3[1] = 8, a__1[1] = xern1; - i__3[2] = 49, a__1[2] = " REQUESTED EXCEEDS THE HIGHEST ORDER FIT, NORD " - "= "; - i__3[3] = 8, a__1[3] = xern2; - i__3[4] = 45, a__1[4] = ", COMPUTED BY DPOLFT -- EXECUTION TERMINATED."; - s_cat(ch__1, a__1, i__3, &c__5, (ftnlen)150); - xermsg_("SLATEC", "DP1VLU", ch__1, &c__8, &c__2, (ftnlen)6, (ftnlen)6, ( - ftnlen)150); - return 0; - -L12: - xermsg_("SLATEC", "DP1VLU", "INVALID INPUT PARAMETER. ORDER OF POLYNOMI" - "AL EVALUATION REQUESTED IS NEGATIVE.", &c__2, &c__2, (ftnlen)6, ( - ftnlen)6, (ftnlen)79); - return 0; -} /* dp1vlu_ */ - diff --git a/ext/f2c_math/dpcoef.c b/ext/f2c_math/dpcoef.c deleted file mode 100644 index 5c3b9a818..000000000 --- a/ext/f2c_math/dpcoef.c +++ /dev/null @@ -1,114 +0,0 @@ -/* dpcoef.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* DECK DPCOEF */ -/* Subroutine */ int dpcoef_(integer *l, doublereal *c__, doublereal *tc, - doublereal *a) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, ll, nr; - doublereal fac; - integer new__, llp1, llp2; - doublereal save; - extern /* Subroutine */ int dp1vlu_(integer *, integer *, doublereal *, - doublereal *, doublereal *, doublereal *); - -/* ***BEGIN PROLOGUE DPCOEF */ -/* ***PURPOSE Convert the DPOLFT coefficients to Taylor series form. */ -/* ***LIBRARY SLATEC */ -/* ***CATEGORY K1A1A2 */ -/* ***TYPE DOUBLE PRECISION (PCOEF-S, DPCOEF-D) */ -/* ***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT */ -/* ***AUTHOR Shampine, L. F., (SNLA) */ -/* Davenport, S. M., (SNLA) */ -/* ***DESCRIPTION */ - -/* Abstract */ - -/* DPOLFT computes the least squares polynomial fit of degree L as */ -/* a sum of orthogonal polynomials. DPCOEF changes this fit to its */ -/* Taylor expansion about any point C , i.e. writes the polynomial */ -/* as a sum of powers of (X-C). Taking C=0. gives the polynomial */ -/* in powers of X, but a suitable non-zero C often leads to */ -/* polynomials which are better scaled and more accurately evaluated. */ - -/* The parameters for DPCOEF are */ - -/* INPUT -- All TYPE REAL variables are DOUBLE PRECISION */ -/* L - Indicates the degree of polynomial to be changed to */ -/* its Taylor expansion. To obtain the Taylor */ -/* coefficients in reverse order, input L as the */ -/* negative of the degree desired. The absolute value */ -/* of L must be less than or equal to NDEG, the highest */ -/* degree polynomial fitted by DPOLFT . */ -/* C - The point about which the Taylor expansion is to be */ -/* made. */ -/* A - Work and output array containing values from last */ -/* call to DPOLFT . */ - -/* OUTPUT -- All TYPE REAL variables are DOUBLE PRECISION */ -/* TC - Vector containing the first LL+1 Taylor coefficients */ -/* where LL=ABS(L). If L.GT.0 , the coefficients are */ -/* in the usual Taylor series order, i.e. */ -/* P(X) = TC(1) + TC(2)*(X-C) + ... + TC(N+1)*(X-C)**N */ -/* If L .LT. 0, the coefficients are in reverse order, */ -/* i.e. */ -/* P(X) = TC(1)*(X-C)**N + ... + TC(N)*(X-C) + TC(N+1) */ - -/* ***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, */ -/* Curve fitting by polynomials in one variable, Report */ -/* SLA-74-0270, Sandia Laboratories, June 1974. */ -/* ***ROUTINES CALLED DP1VLU */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 740601 DATE WRITTEN */ -/* 890531 Changed all specific intrinsics to generic. (WRB) */ -/* 891006 Cosmetic changes to prologue. (WRB) */ -/* 891006 REVISION DATE from Version 3.2 */ -/* 891214 Prologue converted to Version 4.0 format. (BAB) */ -/* 920501 Reformatted the REFERENCES section. (WRB) */ -/* ***END PROLOGUE DPCOEF */ - -/* ***FIRST EXECUTABLE STATEMENT DPCOEF */ - /* Parameter adjustments */ - --a; - --tc; - - /* Function Body */ - ll = abs(*l); - llp1 = ll + 1; - dp1vlu_(&ll, &ll, c__, &tc[1], &tc[2], &a[1]); - if (ll < 2) { - goto L2; - } - fac = 1.; - i__1 = llp1; - for (i__ = 3; i__ <= i__1; ++i__) { - fac *= i__ - 1; -/* L1: */ - tc[i__] /= fac; - } -L2: - if (*l >= 0) { - goto L4; - } - nr = llp1 / 2; - llp2 = ll + 2; - i__1 = nr; - for (i__ = 1; i__ <= i__1; ++i__) { - save = tc[i__]; - new__ = llp2 - i__; - tc[i__] = tc[new__]; -/* L3: */ - tc[new__] = save; - } -L4: - return 0; -} /* dpcoef_ */ - diff --git a/ext/f2c_math/dpolft.c b/ext/f2c_math/dpolft.c deleted file mode 100644 index 5bc670187..000000000 --- a/ext/f2c_math/dpolft.c +++ /dev/null @@ -1,526 +0,0 @@ -/* dpolft.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__2 = 2; -static integer c__1 = 1; - -/* DECK DPOLFT */ -/* Subroutine */ int dpolft_(integer *n, doublereal *x, doublereal *y, - doublereal *w, integer *maxdeg, integer *ndeg, doublereal *eps, - doublereal *r__, integer *ierr, doublereal *a) -{ - /* System generated locals */ - integer i__1; - doublereal d__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - doublereal f; - integer i__, j, m, k1, k2, k3, k4, k5; - doublereal w1, co[12] /* was [4][3] */, w11, xm, yp; - integer jp1; - doublereal den, sig; - integer k1pj, k2pj, k3pi, k4pi, k5pi, mop1; - doublereal degf; - integer nder; - doublereal sigj; - integer jpas, ksig; - doublereal temp, etst, temd1, temd2; - integer idegf, nfail; - doublereal fcrit, sigjm1; - extern /* Subroutine */ int dp1vlu_(integer *, integer *, doublereal *, - doublereal *, doublereal *, doublereal *); - doublereal sigpas; - extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *, - integer *, ftnlen, ftnlen, ftnlen); - -/* ***BEGIN PROLOGUE DPOLFT */ -/* ***PURPOSE Fit discrete data in a least squares sense by polynomials */ -/* in one variable. */ -/* ***LIBRARY SLATEC */ -/* ***CATEGORY K1A1A2 */ -/* ***TYPE DOUBLE PRECISION (POLFIT-S, DPOLFT-D) */ -/* ***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT */ -/* ***AUTHOR Shampine, L. F., (SNLA) */ -/* Davenport, S. M., (SNLA) */ -/* Huddleston, R. E., (SNLL) */ -/* ***DESCRIPTION */ - -/* Abstract */ - -/* Given a collection of points X(I) and a set of values Y(I) which */ -/* correspond to some function or measurement at each of the X(I), */ -/* subroutine DPOLFT computes the weighted least-squares polynomial */ -/* fits of all degrees up to some degree either specified by the user */ -/* or determined by the routine. The fits thus obtained are in */ -/* orthogonal polynomial form. Subroutine DP1VLU may then be */ -/* called to evaluate the fitted polynomials and any of their */ -/* derivatives at any point. The subroutine DPCOEF may be used to */ -/* express the polynomial fits as powers of (X-C) for any specified */ -/* point C. */ - -/* The parameters for DPOLFT are */ - -/* Input -- All TYPE REAL variables are DOUBLE PRECISION */ -/* N - the number of data points. The arrays X, Y and W */ -/* must be dimensioned at least N (N .GE. 1). */ -/* X - array of values of the independent variable. These */ -/* values may appear in any order and need not all be */ -/* distinct. */ -/* Y - array of corresponding function values. */ -/* W - array of positive values to be used as weights. If */ -/* W(1) is negative, DPOLFT will set all the weights */ -/* to 1.0, which means unweighted least squares error */ -/* will be minimized. To minimize relative error, the */ -/* user should set the weights to: W(I) = 1.0/Y(I)**2, */ -/* I = 1,...,N . */ -/* MAXDEG - maximum degree to be allowed for polynomial fit. */ -/* MAXDEG may be any non-negative integer less than N. */ -/* Note -- MAXDEG cannot be equal to N-1 when a */ -/* statistical test is to be used for degree selection, */ -/* i.e., when input value of EPS is negative. */ -/* EPS - specifies the criterion to be used in determining */ -/* the degree of fit to be computed. */ -/* (1) If EPS is input negative, DPOLFT chooses the */ -/* degree based on a statistical F test of */ -/* significance. One of three possible */ -/* significance levels will be used: .01, .05 or */ -/* .10. If EPS=-1.0 , the routine will */ -/* automatically select one of these levels based */ -/* on the number of data points and the maximum */ -/* degree to be considered. If EPS is input as */ -/* -.01, -.05, or -.10, a significance level of */ -/* .01, .05, or .10, respectively, will be used. */ -/* (2) If EPS is set to 0., DPOLFT computes the */ -/* polynomials of degrees 0 through MAXDEG . */ -/* (3) If EPS is input positive, EPS is the RMS */ -/* error tolerance which must be satisfied by the */ -/* fitted polynomial. DPOLFT will increase the */ -/* degree of fit until this criterion is met or */ -/* until the maximum degree is reached. */ - -/* Output -- All TYPE REAL variables are DOUBLE PRECISION */ -/* NDEG - degree of the highest degree fit computed. */ -/* EPS - RMS error of the polynomial of degree NDEG . */ -/* R - vector of dimension at least NDEG containing values */ -/* of the fit of degree NDEG at each of the X(I) . */ -/* Except when the statistical test is used, these */ -/* values are more accurate than results from subroutine */ -/* DP1VLU normally are. */ -/* IERR - error flag with the following possible values. */ -/* 1 -- indicates normal execution, i.e., either */ -/* (1) the input value of EPS was negative, and the */ -/* computed polynomial fit of degree NDEG */ -/* satisfies the specified F test, or */ -/* (2) the input value of EPS was 0., and the fits of */ -/* all degrees up to MAXDEG are complete, or */ -/* (3) the input value of EPS was positive, and the */ -/* polynomial of degree NDEG satisfies the RMS */ -/* error requirement. */ -/* 2 -- invalid input parameter. At least one of the input */ -/* parameters has an illegal value and must be corrected */ -/* before DPOLFT can proceed. Valid input results */ -/* when the following restrictions are observed */ -/* N .GE. 1 */ -/* 0 .LE. MAXDEG .LE. N-1 for EPS .GE. 0. */ -/* 0 .LE. MAXDEG .LE. N-2 for EPS .LT. 0. */ -/* W(1)=-1.0 or W(I) .GT. 0., I=1,...,N . */ -/* 3 -- cannot satisfy the RMS error requirement with a */ -/* polynomial of degree no greater than MAXDEG . Best */ -/* fit found is of degree MAXDEG . */ -/* 4 -- cannot satisfy the test for significance using */ -/* current value of MAXDEG . Statistically, the */ -/* best fit found is of order NORD . (In this case, */ -/* NDEG will have one of the values: MAXDEG-2, */ -/* MAXDEG-1, or MAXDEG). Using a higher value of */ -/* MAXDEG may result in passing the test. */ -/* A - work and output array having at least 3N+3MAXDEG+3 */ -/* locations */ - -/* Note - DPOLFT calculates all fits of degrees up to and including */ -/* NDEG . Any or all of these fits can be evaluated or */ -/* expressed as powers of (X-C) using DP1VLU and DPCOEF */ -/* after just one call to DPOLFT . */ - -/* ***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, */ -/* Curve fitting by polynomials in one variable, Report */ -/* SLA-74-0270, Sandia Laboratories, June 1974. */ -/* ***ROUTINES CALLED DP1VLU, XERMSG */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 740601 DATE WRITTEN */ -/* 890531 Changed all specific intrinsics to generic. (WRB) */ -/* 891006 Cosmetic changes to prologue. (WRB) */ -/* 891006 REVISION DATE from Version 3.2 */ -/* 891214 Prologue converted to Version 4.0 format. (BAB) */ -/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */ -/* 900911 Added variable YP to DOUBLE PRECISION declaration. (WRB) */ -/* 920501 Reformatted the REFERENCES section. (WRB) */ -/* 920527 Corrected erroneous statements in DESCRIPTION. (WRB) */ -/* ***END PROLOGUE DPOLFT */ -/* SAVE CO */ -/* DATA CO(1,1), CO(2,1), CO(3,1), CO(4,1), CO(1,2), CO(2,2), */ -/* 1 CO(3,2), CO(4,2), CO(1,3), CO(2,3), CO(3,3), */ -/* 2 CO(4,3)/-13.086850D0,-2.4648165D0,-3.3846535D0,-1.2973162D0, */ -/* 3 -3.3381146D0,-1.7812271D0,-3.2578406D0,-1.6589279D0, */ -/* 4 -1.6282703D0,-1.3152745D0,-3.2640179D0,-1.9829776D0/ */ -/* ***FIRST EXECUTABLE STATEMENT DPOLFT */ -/* write(*,*) 'DPOLFT n = ',n */ -/* do ii = 1,n */ -/* write(*,*) x(ii), y(ii), w(ii) */ -/* end do */ -/* write(*,*) ' maxdeg, eps = ',maxdeg,eps */ - /* Parameter adjustments */ - --a; - --r__; - --w; - --y; - --x; - - /* Function Body */ - m = abs(*n); - if (m == 0) { - goto L30; - } - if (*maxdeg < 0) { - goto L30; - } - a[1] = (doublereal) (*maxdeg); - mop1 = *maxdeg + 1; - if (m < mop1) { - goto L30; - } - if (*eps < 0. && m == mop1) { - goto L30; - } - xm = (doublereal) m; - etst = *eps * *eps * xm; - if (w[1] < 0.) { - goto L2; - } - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - if (w[i__] <= 0.) { - goto L30; - } -/* L1: */ - } - goto L4; -L2: - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L3: */ - w[i__] = 1.; - } -L4: - if (*eps >= 0.) { - goto L8; - } - -/* DETERMINE SIGNIFICANCE LEVEL INDEX TO BE USED IN STATISTICAL TEST FOR */ -/* CHOOSING DEGREE OF POLYNOMIAL FIT */ - - if (*eps > -.55) { - goto L5; - } - idegf = m - *maxdeg - 1; - ksig = 1; - if (idegf < 10) { - ksig = 2; - } - if (idegf < 5) { - ksig = 3; - } - goto L8; -L5: - ksig = 1; - if (*eps < -.03) { - ksig = 2; - } - if (*eps < -.07) { - ksig = 3; - } - -/* INITIALIZE INDEXES AND COEFFICIENTS FOR FITTING */ - -L8: - k1 = *maxdeg + 1; - k2 = k1 + *maxdeg; - k3 = k2 + *maxdeg + 2; - k4 = k3 + m; - k5 = k4 + m; - i__1 = k4; - for (i__ = 2; i__ <= i__1; ++i__) { -/* L9: */ - a[i__] = 0.; - } - w11 = 0.; - if (*n < 0) { - goto L11; - } - -/* UNCONSTRAINED CASE */ - - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - k4pi = k4 + i__; - a[k4pi] = 1.; -/* L10: */ - w11 += w[i__]; - } - goto L13; - -/* CONSTRAINED CASE */ - -L11: - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - k4pi = k4 + i__; -/* L12: */ -/* Computing 2nd power */ - d__1 = a[k4pi]; - w11 += w[i__] * (d__1 * d__1); - } - -/* COMPUTE FIT OF DEGREE ZERO */ - -L13: - temd1 = 0.; - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - k4pi = k4 + i__; - temd1 += w[i__] * y[i__] * a[k4pi]; -/* L14: */ - } - temd1 /= w11; - a[k2 + 1] = temd1; - sigj = 0.; - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - k4pi = k4 + i__; - k5pi = k5 + i__; - temd2 = temd1 * a[k4pi]; - r__[i__] = temd2; - a[k5pi] = temd2 - r__[i__]; -/* L15: */ -/* Computing 2nd power */ - d__1 = y[i__] - r__[i__] - a[k5pi]; - sigj += w[i__] * (d__1 * d__1); - } - j = 0; - -/* SEE IF POLYNOMIAL OF DEGREE 0 SATISFIES THE DEGREE SELECTION CRITERION */ - - if (*eps < 0.) { - goto L24; - } else if (*eps == 0) { - goto L26; - } else { - goto L27; - } - -/* INCREMENT DEGREE */ - -L16: - ++j; - jp1 = j + 1; - k1pj = k1 + j; - k2pj = k2 + j; - sigjm1 = sigj; - -/* COMPUTE NEW B COEFFICIENT EXCEPT WHEN J = 1 */ - - if (j > 1) { - a[k1pj] = w11 / w1; - } - -/* COMPUTE NEW A COEFFICIENT */ - - temd1 = 0.; - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - k4pi = k4 + i__; - temd2 = a[k4pi]; - temd1 += x[i__] * w[i__] * temd2 * temd2; -/* L18: */ - } - a[jp1] = temd1 / w11; - -/* EVALUATE ORTHOGONAL POLYNOMIAL AT DATA POINTS */ - - w1 = w11; - w11 = 0.; - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - k3pi = k3 + i__; - k4pi = k4 + i__; - temp = a[k3pi]; - a[k3pi] = a[k4pi]; - a[k4pi] = (x[i__] - a[jp1]) * a[k3pi] - a[k1pj] * temp; -/* L19: */ -/* Computing 2nd power */ - d__1 = a[k4pi]; - w11 += w[i__] * (d__1 * d__1); - } - -/* GET NEW ORTHOGONAL POLYNOMIAL COEFFICIENT USING PARTIAL DOUBLE */ -/* PRECISION */ - - temd1 = 0.; - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - k4pi = k4 + i__; - k5pi = k5 + i__; - temd2 = w[i__] * (y[i__] - r__[i__] - a[k5pi]) * a[k4pi]; -/* L20: */ - temd1 += temd2; - } - temd1 /= w11; - a[k2pj + 1] = temd1; - -/* UPDATE POLYNOMIAL EVALUATIONS AT EACH OF THE DATA POINTS, AND */ -/* ACCUMULATE SUM OF SQUARES OF ERRORS. THE POLYNOMIAL EVALUATIONS ARE */ -/* COMPUTED AND STORED IN EXTENDED PRECISION. FOR THE I-TH DATA POINT, */ -/* THE MOST SIGNIFICANT BITS ARE STORED IN R(I) , AND THE LEAST */ -/* SIGNIFICANT BITS ARE IN A(K5PI) . */ - - sigj = 0.; - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - k4pi = k4 + i__; - k5pi = k5 + i__; - temd2 = r__[i__] + a[k5pi] + temd1 * a[k4pi]; - r__[i__] = temd2; - a[k5pi] = temd2 - r__[i__]; -/* L21: */ -/* Computing 2nd power */ - d__1 = y[i__] - r__[i__] - a[k5pi]; - sigj += w[i__] * (d__1 * d__1); - } - -/* SEE IF DEGREE SELECTION CRITERION HAS BEEN SATISFIED OR IF DEGREE */ -/* MAXDEG HAS BEEN REACHED */ - - if (*eps < 0.) { - goto L23; - } else if (*eps == 0) { - goto L26; - } else { - goto L27; - } - -/* COMPUTE F STATISTICS (INPUT EPS .LT. 0.) */ - -L23: - if (sigj == 0.) { - goto L29; - } - degf = (doublereal) (m - j - 1); - den = (co[(ksig << 2) - 1] * degf + 1.) * degf; - fcrit = ((co[(ksig << 2) - 2] * degf + co[(ksig << 2) - 3]) * degf + co[( - ksig << 2) - 4]) / den; - fcrit *= fcrit; - f = (sigjm1 - sigj) * degf / sigj; - if (f < fcrit) { - goto L25; - } - -/* POLYNOMIAL OF DEGREE J SATISFIES F TEST */ - -L24: - sigpas = sigj; - jpas = j; - nfail = 0; - if (*maxdeg == j) { - goto L32; - } - goto L16; - -/* POLYNOMIAL OF DEGREE J FAILS F TEST. IF THERE HAVE BEEN THREE */ -/* SUCCESSIVE FAILURES, A STATISTICALLY BEST DEGREE HAS BEEN FOUND. */ - -L25: - ++nfail; - if (nfail >= 3) { - goto L29; - } - if (*maxdeg == j) { - goto L32; - } - goto L16; - -/* RAISE THE DEGREE IF DEGREE MAXDEG HAS NOT YET BEEN REACHED (INPUT */ -/* EPS = 0.) */ - -L26: - if (*maxdeg == j) { - goto L28; - } - goto L16; - -/* SEE IF RMS ERROR CRITERION IS SATISFIED (INPUT EPS .GT. 0.) */ - -L27: - if (sigj <= etst) { - goto L28; - } - if (*maxdeg == j) { - goto L31; - } - goto L16; - -/* RETURNS */ - -L28: - *ierr = 1; - *ndeg = j; - sig = sigj; - goto L33; -L29: - *ierr = 1; - *ndeg = jpas; - sig = sigpas; - goto L33; -L30: - *ierr = 2; - xermsg_("SLATEC", "DPOLFT", "INVALID INPUT PARAMETER.", &c__2, &c__1, ( - ftnlen)6, (ftnlen)6, (ftnlen)24); - goto L37; -L31: - *ierr = 3; - *ndeg = *maxdeg; - sig = sigj; - goto L33; -L32: - *ierr = 4; - *ndeg = jpas; - sig = sigpas; - -L33: - a[k3] = (doublereal) (*ndeg); - -/* WHEN STATISTICAL TEST HAS BEEN USED, EVALUATE THE BEST POLYNOMIAL AT */ -/* ALL THE DATA POINTS IF R DOES NOT ALREADY CONTAIN THESE VALUES */ - - if (*eps >= 0.f || *ndeg == *maxdeg) { - goto L36; - } - nder = 0; - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - dp1vlu_(ndeg, &nder, &x[i__], &r__[i__], &yp, &a[1]); -/* L35: */ - } -L36: - *eps = sqrt(sig / xm); -L37: - return 0; -} /* dpolft_ */ - diff --git a/ext/f2c_math/fdump.c b/ext/f2c_math/fdump.c deleted file mode 100644 index 2438c6698..000000000 --- a/ext/f2c_math/fdump.c +++ /dev/null @@ -1,40 +0,0 @@ -/* fdump.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* DECK FDUMP */ -/* Subroutine */ int fdump_(void) -{ -/* ***BEGIN PROLOGUE FDUMP */ -/* ***PURPOSE Symbolic dump (should be locally written). */ -/* ***LIBRARY SLATEC (XERMSG) */ -/* ***CATEGORY R3 */ -/* ***TYPE ALL (FDUMP-A) */ -/* ***KEYWORDS ERROR, XERMSG */ -/* ***AUTHOR Jones, R. E., (SNLA) */ -/* ***DESCRIPTION */ - -/* ***Note*** Machine Dependent Routine */ -/* FDUMP is intended to be replaced by a locally written */ -/* version which produces a symbolic dump. Failing this, */ -/* it should be replaced by a version which prints the */ -/* subprogram nesting list. Note that this dump must be */ -/* printed on each of up to five files, as indicated by the */ -/* XGETUA routine. See XSETUA and XGETUA for details. */ - -/* Written by Ron Jones, with SLATEC Common Math Library Subcommittee */ - -/* ***REFERENCES (NONE) */ -/* ***ROUTINES CALLED (NONE) */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 790801 DATE WRITTEN */ -/* 861211 REVISION DATE from Version 3.2 */ -/* 891214 Prologue converted to Version 4.0 format. (BAB) */ -/* ***END PROLOGUE FDUMP */ -/* ***FIRST EXECUTABLE STATEMENT FDUMP */ - return 0; -} /* fdump_ */ - diff --git a/ext/f2c_math/j4save.c b/ext/f2c_math/j4save.c deleted file mode 100644 index db219b885..000000000 --- a/ext/f2c_math/j4save.c +++ /dev/null @@ -1,78 +0,0 @@ -/* j4save.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* DECK J4SAVE */ -integer j4save_(integer *iwhich, integer *ivalue, logical *iset) -{ - /* Initialized data */ - - static integer iparam[9] = { 0,2,0,10,1,0,0,0,0 }; - - /* System generated locals */ - integer ret_val; - -/* ***BEGIN PROLOGUE J4SAVE */ -/* ***SUBSIDIARY */ -/* ***PURPOSE Save or recall global variables needed by error */ -/* handling routines. */ -/* ***LIBRARY SLATEC (XERROR) */ -/* ***TYPE INTEGER (J4SAVE-I) */ -/* ***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR */ -/* ***AUTHOR Jones, R. E., (SNLA) */ -/* ***DESCRIPTION */ - -/* Abstract */ -/* J4SAVE saves and recalls several global variables needed */ -/* by the library error handling routines. */ - -/* Description of Parameters */ -/* --Input-- */ -/* IWHICH - Index of item desired. */ -/* = 1 Refers to current error number. */ -/* = 2 Refers to current error control flag. */ -/* = 3 Refers to current unit number to which error */ -/* messages are to be sent. (0 means use standard.) */ -/* = 4 Refers to the maximum number of times any */ -/* message is to be printed (as set by XERMAX). */ -/* = 5 Refers to the total number of units to which */ -/* each error message is to be written. */ -/* = 6 Refers to the 2nd unit for error messages */ -/* = 7 Refers to the 3rd unit for error messages */ -/* = 8 Refers to the 4th unit for error messages */ -/* = 9 Refers to the 5th unit for error messages */ -/* IVALUE - The value to be set for the IWHICH-th parameter, */ -/* if ISET is .TRUE. . */ -/* ISET - If ISET=.TRUE., the IWHICH-th parameter will BE */ -/* given the value, IVALUE. If ISET=.FALSE., the */ -/* IWHICH-th parameter will be unchanged, and IVALUE */ -/* is a dummy parameter. */ -/* --Output-- */ -/* The (old) value of the IWHICH-th parameter will be returned */ -/* in the function value, J4SAVE. */ - -/* ***SEE ALSO XERMSG */ -/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ -/* Error-handling Package, SAND82-0800, Sandia */ -/* Laboratories, 1982. */ -/* ***ROUTINES CALLED (NONE) */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 790801 DATE WRITTEN */ -/* 891214 Prologue converted to Version 4.0 format. (BAB) */ -/* 900205 Minor modifications to prologue. (WRB) */ -/* 900402 Added TYPE section. (WRB) */ -/* 910411 Added KEYWORDS section. (WRB) */ -/* 920501 Reformatted the REFERENCES section. (WRB) */ -/* ***END PROLOGUE J4SAVE */ -/* SAVE IPARAM */ -/* ***FIRST EXECUTABLE STATEMENT J4SAVE */ - ret_val = iparam[(0 + (0 + ((*iwhich - 1) << 2))) / 4]; - if (*iset) { - iparam[*iwhich - 1] = *ivalue; - } - return ret_val; -} /* j4save_ */ - diff --git a/ext/f2c_math/mach.cpp b/ext/f2c_math/mach.cpp deleted file mode 100644 index de90e1c4b..000000000 --- a/ext/f2c_math/mach.cpp +++ /dev/null @@ -1,88 +0,0 @@ - -/* Standard C source for D1MACH -- remove the * in column 1 */ -#include -#include -#include -#include -#include - -extern "C" { - - double d1mach_(long* i) - { - switch (*i) { - case 1: - return DBL_MIN; - case 2: - return DBL_MAX; - case 3: - return DBL_EPSILON/FLT_RADIX; - case 4: - return DBL_EPSILON; - case 5: - return log10((double)FLT_RADIX); - } - fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i); - exit(1); - return 0; /* some compilers demand return values */ - } - - double d1mach(long* i) - { - return d1mach_(i); - } - - - long i1mach_(long* i) - { - switch (*i) { - case 1: - return 5; /* standard input */ - case 2: - return 6; /* standard output */ - case 3: - return 7; /* standard punch */ - case 4: - return 0; /* standard error */ - case 5: - return 32; /* bits per integer */ - case 6: - return sizeof(int); - case 7: - return 2; /* base for integers */ - case 8: - return 31; /* digits of integer base */ - case 9: - return LONG_MAX; - case 10: - return FLT_RADIX; - case 11: - return FLT_MANT_DIG; - case 12: - return FLT_MIN_EXP; - case 13: - return FLT_MAX_EXP; - case 14: - return DBL_MANT_DIG; - case 15: - return DBL_MIN_EXP; - case 16: - return DBL_MAX_EXP; - } - fprintf(stderr, "invalid argument: i1mach(%ld)\n", *i); - exit(1); - return 0; /* some compilers demand return values */ - } - - long i1mach(long* i) - { - return i1mach_(i); - } - - long _i1mach_(long* i) - { - return i1mach_(i); - } - -} - diff --git a/ext/f2c_math/pcoef.c b/ext/f2c_math/pcoef.c deleted file mode 100644 index 08494b831..000000000 --- a/ext/f2c_math/pcoef.c +++ /dev/null @@ -1,993 +0,0 @@ -/* pcoef.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/* DECK PCOEF */ -/* Subroutine */ int pcoef_(integer *l, real *c__, real *tc, real *a) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, ll, nr; - real fac; - integer new__, llp1, llp2; - real save; - extern /* Subroutine */ int pvalue_(integer *, integer *, real *, real *, - real *, real *); - -/* ***BEGIN PROLOGUE PCOEF */ -/* ***PURPOSE Convert the POLFIT coefficients to Taylor series form. */ -/* ***LIBRARY SLATEC */ -/* ***CATEGORY K1A1A2 */ -/* ***TYPE SINGLE PRECISION (PCOEF-S, DPCOEF-D) */ -/* ***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT */ -/* ***AUTHOR Shampine, L. F., (SNLA) */ -/* Davenport, S. M., (SNLA) */ -/* ***DESCRIPTION */ - -/* Written BY L. F. Shampine and S. M. Davenport. */ - -/* Abstract */ - -/* POLFIT computes the least squares polynomial fit of degree L as */ -/* a sum of orthogonal polynomials. PCOEF changes this fit to its */ -/* Taylor expansion about any point C , i.e. writes the polynomial */ -/* as a sum of powers of (X-C). Taking C=0. gives the polynomial */ -/* in powers of X, but a suitable non-zero C often leads to */ -/* polynomials which are better scaled and more accurately evaluated. */ - -/* The parameters for PCOEF are */ - -/* INPUT -- */ -/* L - Indicates the degree of polynomial to be changed to */ -/* its Taylor expansion. To obtain the Taylor */ -/* coefficients in reverse order, input L as the */ -/* negative of the degree desired. The absolute value */ -/* of L must be less than or equal to NDEG, the highest */ -/* degree polynomial fitted by POLFIT . */ -/* C - The point about which the Taylor expansion is to be */ -/* made. */ -/* A - Work and output array containing values from last */ -/* call to POLFIT . */ - -/* OUTPUT -- */ -/* TC - Vector containing the first LL+1 Taylor coefficients */ -/* where LL=ABS(L). If L.GT.0 , the coefficients are */ -/* in the usual Taylor series order, i.e. */ -/* P(X) = TC(1) + TC(2)*(X-C) + ... + TC(N+1)*(X-C)**N */ -/* If L .LT. 0, the coefficients are in reverse order, */ -/* i.e. */ -/* P(X) = TC(1)*(X-C)**N + ... + TC(N)*(X-C) + TC(N+1) */ - -/* ***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, */ -/* Curve fitting by polynomials in one variable, Report */ -/* SLA-74-0270, Sandia Laboratories, June 1974. */ -/* ***ROUTINES CALLED PVALUE */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 740601 DATE WRITTEN */ -/* 890531 Changed all specific intrinsics to generic. (WRB) */ -/* 890531 REVISION DATE from Version 3.2 */ -/* 891214 Prologue converted to Version 4.0 format. (BAB) */ -/* 920501 Reformatted the REFERENCES section. (WRB) */ -/* ***END PROLOGUE PCOEF */ - -/* ***FIRST EXECUTABLE STATEMENT PCOEF */ - /* Parameter adjustments */ - --a; - --tc; - - /* Function Body */ - ll = abs(*l); - llp1 = ll + 1; - pvalue_(&ll, &ll, c__, &tc[1], &tc[2], &a[1]); - if (ll < 2) { - goto L2; - } - fac = 1.f; - i__1 = llp1; - for (i__ = 3; i__ <= i__1; ++i__) { - fac *= i__ - 1; -/* L1: */ - tc[i__] /= fac; - } -L2: - if (*l >= 0) { - goto L4; - } - nr = llp1 / 2; - llp2 = ll + 2; - i__1 = nr; - for (i__ = 1; i__ <= i__1; ++i__) { - save = tc[i__]; - new__ = llp2 - i__; - tc[i__] = tc[new__]; -/* L3: */ - tc[new__] = save; - } -L4: - return 0; -} /* pcoef_ */ - -/* $$$ */ -/* $$$ subroutine dscal(n,da,dx,incx) */ -/* $$$c */ -/* $$$c scales a vector by a constant. */ -/* $$$c uses unrolled loops for increment equal to one. */ -/* $$$c jack dongarra, linpack, 3/11/78. */ -/* $$$c modified 3/93 to return if incx .le. 0. */ -/* $$$c */ -/* $$$ double precision da,dx(1) */ -/* $$$ integer i,incx,m,mp1,n,nincx */ -/* $$$c */ -/* $$$ if( n.le.0 .or. incx.le.0 )return */ -/* $$$ if(incx.eq.1)go to 20 */ -/* $$$c */ -/* $$$c code for increment not equal to 1 */ -/* $$$c */ -/* $$$ nincx = n*incx */ -/* $$$ do 10 i = 1,nincx,incx */ -/* $$$ dx(i) = da*dx(i) */ -/* $$$ 10 continue */ -/* $$$ return */ -/* $$$c */ -/* $$$c code for increment equal to 1 */ -/* $$$c */ -/* $$$c */ -/* $$$c clean-up loop */ -/* $$$c */ -/* $$$ 20 m = mod(n,5) */ -/* $$$ if( m .eq. 0 ) go to 40 */ -/* $$$ do 30 i = 1,m */ -/* $$$ dx(i) = da*dx(i) */ -/* $$$ 30 continue */ -/* $$$ if( n .lt. 5 ) return */ -/* $$$ 40 mp1 = m + 1 */ -/* $$$ do 50 i = mp1,n,5 */ -/* $$$ dx(i) = da*dx(i) */ -/* $$$ dx(i + 1) = da*dx(i + 1) */ -/* $$$ dx(i + 2) = da*dx(i + 2) */ -/* $$$ dx(i + 3) = da*dx(i + 3) */ -/* $$$ dx(i + 4) = da*dx(i + 4) */ -/* $$$ 50 continue */ -/* $$$ return */ -/* $$$ end */ -/* Subroutine */ int dgbco_(doublereal *abd, integer *lda, integer *n, - integer *ml, integer *mu, integer *ipvt, doublereal *rcond, - doublereal *z__) -{ - /* System generated locals */ - integer abd_dim1, abd_offset, i__1, i__2, i__3, i__4; - doublereal d__1, d__2; - - /* Builtin functions */ - double d_sign(doublereal *, doublereal *); - - /* Local variables */ - integer j, k, l, m; - doublereal s, t; - integer kb, la; - doublereal ek; - integer lm, mm, is, ju; - doublereal sm, wk; - integer lz, kp1; - doublereal wkm; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); - integer info; - extern /* Subroutine */ int dgbfa_(doublereal *, integer *, integer *, - integer *, integer *, integer *, integer *), dscal_(integer *, - doublereal *, doublereal *, integer *); - extern doublereal dasum_(integer *, doublereal *, integer *); - doublereal anorm; - extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - doublereal ynorm; - - -/* dgbco factors a double precision band matrix by gaussian */ -/* elimination and estimates the condition of the matrix. */ - -/* if rcond is not needed, dgbfa is slightly faster. */ -/* to solve a*x = b , follow dgbco by dgbsl. */ -/* to compute inverse(a)*c , follow dgbco by dgbsl. */ -/* to compute determinant(a) , follow dgbco by dgbdi. */ - -/* on entry */ - -/* abd double precision(lda, n) */ -/* contains the matrix in band storage. the columns */ -/* of the matrix are stored in the columns of abd and */ -/* the diagonals of the matrix are stored in rows */ -/* ml+1 through 2*ml+mu+1 of abd . */ -/* see the comments below for details. */ - -/* lda integer */ -/* the leading dimension of the array abd . */ -/* lda must be .ge. 2*ml + mu + 1 . */ - -/* n integer */ -/* the order of the original matrix. */ - -/* ml integer */ -/* number of diagonals below the main diagonal. */ -/* 0 .le. ml .lt. n . */ - -/* mu integer */ -/* number of diagonals above the main diagonal. */ -/* 0 .le. mu .lt. n . */ -/* more efficient if ml .le. mu . */ - -/* on return */ - -/* abd an upper triangular matrix in band storage and */ -/* the multipliers which were used to obtain it. */ -/* the factorization can be written a = l*u where */ -/* l is a product of permutation and unit lower */ -/* triangular matrices and u is upper triangular. */ - -/* ipvt integer(n) */ -/* an integer vector of pivot indices. */ - -/* rcond double precision */ -/* an estimate of the reciprocal condition of a . */ -/* for the system a*x = b , relative perturbations */ -/* in a and b of size epsilon may cause */ -/* relative perturbations in x of size epsilon/rcond . */ -/* if rcond is so small that the logical expression */ -/* 1.0 + rcond .eq. 1.0 */ -/* is true, then a may be singular to working */ -/* precision. in particular, rcond is zero if */ -/* exact singularity is detected or the estimate */ -/* underflows. */ - -/* z double precision(n) */ -/* a work vector whose contents are usually unimportant. */ -/* if a is close to a singular matrix, then z is */ -/* an approximate null vector in the sense that */ -/* norm(a*z) = rcond*norm(a)*norm(z) . */ - -/* band storage */ - -/* if a is a band matrix, the following program segment */ -/* will set up the input. */ - -/* ml = (band width below the diagonal) */ -/* mu = (band width above the diagonal) */ -/* m = ml + mu + 1 */ -/* do 20 j = 1, n */ -/* i1 = max0(1, j-mu) */ -/* i2 = min0(n, j+ml) */ -/* do 10 i = i1, i2 */ -/* k = i - j + m */ -/* abd(k,j) = a(i,j) */ -/* 10 continue */ -/* 20 continue */ - -/* this uses rows ml+1 through 2*ml+mu+1 of abd . */ -/* in addition, the first ml rows in abd are used for */ -/* elements generated during the triangularization. */ -/* the total number of rows needed in abd is 2*ml+mu+1 . */ -/* the ml+mu by ml+mu upper left triangle and the */ -/* ml by ml lower right triangle are not referenced. */ - -/* example.. if the original matrix is */ - -/* 11 12 13 0 0 0 */ -/* 21 22 23 24 0 0 */ -/* 0 32 33 34 35 0 */ -/* 0 0 43 44 45 46 */ -/* 0 0 0 54 55 56 */ -/* 0 0 0 0 65 66 */ - -/* then n = 6, ml = 1, mu = 2, lda .ge. 5 and abd should contain */ - -/* * * * + + + , * = not used */ -/* * * 13 24 35 46 , + = used for pivoting */ -/* * 12 23 34 45 56 */ -/* 11 22 33 44 55 66 */ -/* 21 32 43 54 65 * */ - -/* linpack. this version dated 08/14/78 . */ -/* cleve moler, university of new mexico, argonne national lab. */ - -/* subroutines and functions */ - -/* linpack dgbfa */ -/* blas daxpy,ddot,dscal,dasum */ -/* fortran dabs,dmax1,max0,min0,dsign */ - -/* internal variables */ - - - -/* compute 1-norm of a */ - - /* Parameter adjustments */ - abd_dim1 = *lda; - abd_offset = 1 + abd_dim1; - abd -= abd_offset; - --ipvt; - --z__; - - /* Function Body */ - anorm = 0.; - l = *ml + 1; - is = l + *mu; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - d__1 = anorm, d__2 = dasum_(&l, &abd[is + j * abd_dim1], &c__1); - anorm = max(d__1,d__2); - if (is > *ml + 1) { - --is; - } - if (j <= *mu) { - ++l; - } - if (j >= *n - *ml) { - --l; - } -/* L10: */ - } - -/* factor */ - - dgbfa_(&abd[abd_offset], lda, n, ml, mu, &ipvt[1], &info); - -/* rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) . */ -/* estimate = norm(z)/norm(y) where a*z = y and trans(a)*y = e . */ -/* trans(a) is the transpose of a . the components of e are */ -/* chosen to cause maximum local growth in the elements of w where */ -/* trans(u)*w = e . the vectors are frequently rescaled to avoid */ -/* overflow. */ - -/* solve trans(u)*w = e */ - - ek = 1.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - z__[j] = 0.; -/* L20: */ - } - m = *ml + *mu + 1; - ju = 0; - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (z__[k] != 0.) { - d__1 = -z__[k]; - ek = d_sign(&ek, &d__1); - } - if ((d__1 = ek - z__[k], abs(d__1)) <= (d__2 = abd[m + k * abd_dim1], - abs(d__2))) { - goto L30; - } - s = (d__1 = abd[m + k * abd_dim1], abs(d__1)) / (d__2 = ek - z__[k], - abs(d__2)); - dscal_(n, &s, &z__[1], &c__1); - ek = s * ek; -L30: - wk = ek - z__[k]; - wkm = -ek - z__[k]; - s = abs(wk); - sm = abs(wkm); - if (abd[m + k * abd_dim1] == 0.) { - goto L40; - } - wk /= abd[m + k * abd_dim1]; - wkm /= abd[m + k * abd_dim1]; - goto L50; -L40: - wk = 1.; - wkm = 1.; -L50: - kp1 = k + 1; -/* Computing MIN */ -/* Computing MAX */ - i__3 = ju, i__4 = *mu + ipvt[k]; - i__2 = max(i__3,i__4); - ju = min(i__2,*n); - mm = m; - if (kp1 > ju) { - goto L90; - } - i__2 = ju; - for (j = kp1; j <= i__2; ++j) { - --mm; - sm += (d__1 = z__[j] + wkm * abd[mm + j * abd_dim1], abs(d__1)); - z__[j] += wk * abd[mm + j * abd_dim1]; - s += (d__1 = z__[j], abs(d__1)); -/* L60: */ - } - if (s >= sm) { - goto L80; - } - t = wkm - wk; - wk = wkm; - mm = m; - i__2 = ju; - for (j = kp1; j <= i__2; ++j) { - --mm; - z__[j] += t * abd[mm + j * abd_dim1]; -/* L70: */ - } -L80: -L90: - z__[k] = wk; -/* L100: */ - } - s = 1. / dasum_(n, &z__[1], &c__1); - dscal_(n, &s, &z__[1], &c__1); - -/* solve trans(l)*y = w */ - - i__1 = *n; - for (kb = 1; kb <= i__1; ++kb) { - k = *n + 1 - kb; -/* Computing MIN */ - i__2 = *ml, i__3 = *n - k; - lm = min(i__2,i__3); - if (k < *n) { - z__[k] += ddot_(&lm, &abd[m + 1 + k * abd_dim1], &c__1, &z__[k + - 1], &c__1); - } - if ((d__1 = z__[k], abs(d__1)) <= 1.) { - goto L110; - } - s = 1. / (d__1 = z__[k], abs(d__1)); - dscal_(n, &s, &z__[1], &c__1); -L110: - l = ipvt[k]; - t = z__[l]; - z__[l] = z__[k]; - z__[k] = t; -/* L120: */ - } - s = 1. / dasum_(n, &z__[1], &c__1); - dscal_(n, &s, &z__[1], &c__1); - - ynorm = 1.; - -/* solve l*v = y */ - - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - l = ipvt[k]; - t = z__[l]; - z__[l] = z__[k]; - z__[k] = t; -/* Computing MIN */ - i__2 = *ml, i__3 = *n - k; - lm = min(i__2,i__3); - if (k < *n) { - daxpy_(&lm, &t, &abd[m + 1 + k * abd_dim1], &c__1, &z__[k + 1], & - c__1); - } - if ((d__1 = z__[k], abs(d__1)) <= 1.) { - goto L130; - } - s = 1. / (d__1 = z__[k], abs(d__1)); - dscal_(n, &s, &z__[1], &c__1); - ynorm = s * ynorm; -L130: -/* L140: */ - ; - } - s = 1. / dasum_(n, &z__[1], &c__1); - dscal_(n, &s, &z__[1], &c__1); - ynorm = s * ynorm; - -/* solve u*z = w */ - - i__1 = *n; - for (kb = 1; kb <= i__1; ++kb) { - k = *n + 1 - kb; - if ((d__1 = z__[k], abs(d__1)) <= (d__2 = abd[m + k * abd_dim1], abs( - d__2))) { - goto L150; - } - s = (d__1 = abd[m + k * abd_dim1], abs(d__1)) / (d__2 = z__[k], abs( - d__2)); - dscal_(n, &s, &z__[1], &c__1); - ynorm = s * ynorm; -L150: - if (abd[m + k * abd_dim1] != 0.) { - z__[k] /= abd[m + k * abd_dim1]; - } - if (abd[m + k * abd_dim1] == 0.) { - z__[k] = 1.; - } - lm = min(k,m) - 1; - la = m - lm; - lz = k - lm; - t = -z__[k]; - daxpy_(&lm, &t, &abd[la + k * abd_dim1], &c__1, &z__[lz], &c__1); -/* L160: */ - } -/* make znorm = 1.0 */ - s = 1. / dasum_(n, &z__[1], &c__1); - dscal_(n, &s, &z__[1], &c__1); - ynorm = s * ynorm; - - if (anorm != 0.) { - *rcond = ynorm / anorm; - } - if (anorm == 0.) { - *rcond = 0.; - } - return 0; -} /* dgbco_ */ - -/* Subroutine */ int dgeco_(doublereal *a, integer *lda, integer *n, integer * - ipvt, doublereal *rcond, doublereal *z__) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - doublereal d__1, d__2; - - /* Builtin functions */ - double d_sign(doublereal *, doublereal *); - - /* Local variables */ - integer j, k, l; - doublereal s, t; - integer kb; - doublereal ek, sm, wk; - integer kp1; - doublereal wkm; - extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, - integer *); - integer info; - extern /* Subroutine */ int dgefa_(doublereal *, integer *, integer *, - integer *, integer *), dscal_(integer *, doublereal *, doublereal - *, integer *); - extern doublereal dasum_(integer *, doublereal *, integer *); - doublereal anorm; - extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - doublereal ynorm; - - -/* dgeco factors a double precision matrix by gaussian elimination */ -/* and estimates the condition of the matrix. */ - -/* if rcond is not needed, dgefa is slightly faster. */ -/* to solve a*x = b , follow dgeco by dgesl. */ -/* to compute inverse(a)*c , follow dgeco by dgesl. */ -/* to compute determinant(a) , follow dgeco by dgedi. */ -/* to compute inverse(a) , follow dgeco by dgedi. */ - -/* on entry */ - -/* a double precision(lda, n) */ -/* the matrix to be factored. */ - -/* lda integer */ -/* the leading dimension of the array a . */ - -/* n integer */ -/* the order of the matrix a . */ - -/* on return */ - -/* a an upper triangular matrix and the multipliers */ -/* which were used to obtain it. */ -/* the factorization can be written a = l*u where */ -/* l is a product of permutation and unit lower */ -/* triangular matrices and u is upper triangular. */ - -/* ipvt integer(n) */ -/* an integer vector of pivot indices. */ - -/* rcond double precision */ -/* an estimate of the reciprocal condition of a . */ -/* for the system a*x = b , relative perturbations */ -/* in a and b of size epsilon may cause */ -/* relative perturbations in x of size epsilon/rcond . */ -/* if rcond is so small that the logical expression */ -/* 1.0 + rcond .eq. 1.0 */ -/* is true, then a may be singular to working */ -/* precision. in particular, rcond is zero if */ -/* exact singularity is detected or the estimate */ -/* underflows. */ - -/* z double precision(n) */ -/* a work vector whose contents are usually unimportant. */ -/* if a is close to a singular matrix, then z is */ -/* an approximate null vector in the sense that */ -/* norm(a*z) = rcond*norm(a)*norm(z) . */ - -/* linpack. this version dated 08/14/78 . */ -/* cleve moler, university of new mexico, argonne national lab. */ - -/* subroutines and functions */ - -/* linpack dgefa */ -/* blas daxpy,ddot,dscal,dasum */ -/* fortran dabs,dmax1,dsign */ - -/* internal variables */ - - - -/* compute 1-norm of a */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipvt; - --z__; - - /* Function Body */ - anorm = 0.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/* Computing MAX */ - d__1 = anorm, d__2 = dasum_(n, &a[j * a_dim1 + 1], &c__1); - anorm = max(d__1,d__2); -/* L10: */ - } - -/* factor */ - - dgefa_(&a[a_offset], lda, n, &ipvt[1], &info); - -/* rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) . */ -/* estimate = norm(z)/norm(y) where a*z = y and trans(a)*y = e . */ -/* trans(a) is the transpose of a . the components of e are */ -/* chosen to cause maximum local growth in the elements of w where */ -/* trans(u)*w = e . the vectors are frequently rescaled to avoid */ -/* overflow. */ - -/* solve trans(u)*w = e */ - - ek = 1.; - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - z__[j] = 0.; -/* L20: */ - } - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - if (z__[k] != 0.) { - d__1 = -z__[k]; - ek = d_sign(&ek, &d__1); - } - if ((d__1 = ek - z__[k], abs(d__1)) <= (d__2 = a[k + k * a_dim1], abs( - d__2))) { - goto L30; - } - s = (d__1 = a[k + k * a_dim1], abs(d__1)) / (d__2 = ek - z__[k], abs( - d__2)); - dscal_(n, &s, &z__[1], &c__1); - ek = s * ek; -L30: - wk = ek - z__[k]; - wkm = -ek - z__[k]; - s = abs(wk); - sm = abs(wkm); - if (a[k + k * a_dim1] == 0.) { - goto L40; - } - wk /= a[k + k * a_dim1]; - wkm /= a[k + k * a_dim1]; - goto L50; -L40: - wk = 1.; - wkm = 1.; -L50: - kp1 = k + 1; - if (kp1 > *n) { - goto L90; - } - i__2 = *n; - for (j = kp1; j <= i__2; ++j) { - sm += (d__1 = z__[j] + wkm * a[k + j * a_dim1], abs(d__1)); - z__[j] += wk * a[k + j * a_dim1]; - s += (d__1 = z__[j], abs(d__1)); -/* L60: */ - } - if (s >= sm) { - goto L80; - } - t = wkm - wk; - wk = wkm; - i__2 = *n; - for (j = kp1; j <= i__2; ++j) { - z__[j] += t * a[k + j * a_dim1]; -/* L70: */ - } -L80: -L90: - z__[k] = wk; -/* L100: */ - } - s = 1. / dasum_(n, &z__[1], &c__1); - dscal_(n, &s, &z__[1], &c__1); - -/* solve trans(l)*y = w */ - - i__1 = *n; - for (kb = 1; kb <= i__1; ++kb) { - k = *n + 1 - kb; - if (k < *n) { - i__2 = *n - k; - z__[k] += ddot_(&i__2, &a[k + 1 + k * a_dim1], &c__1, &z__[k + 1], - &c__1); - } - if ((d__1 = z__[k], abs(d__1)) <= 1.) { - goto L110; - } - s = 1. / (d__1 = z__[k], abs(d__1)); - dscal_(n, &s, &z__[1], &c__1); -L110: - l = ipvt[k]; - t = z__[l]; - z__[l] = z__[k]; - z__[k] = t; -/* L120: */ - } - s = 1. / dasum_(n, &z__[1], &c__1); - dscal_(n, &s, &z__[1], &c__1); - - ynorm = 1.; - -/* solve l*v = y */ - - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - l = ipvt[k]; - t = z__[l]; - z__[l] = z__[k]; - z__[k] = t; - if (k < *n) { - i__2 = *n - k; - daxpy_(&i__2, &t, &a[k + 1 + k * a_dim1], &c__1, &z__[k + 1], & - c__1); - } - if ((d__1 = z__[k], abs(d__1)) <= 1.) { - goto L130; - } - s = 1. / (d__1 = z__[k], abs(d__1)); - dscal_(n, &s, &z__[1], &c__1); - ynorm = s * ynorm; -L130: -/* L140: */ - ; - } - s = 1. / dasum_(n, &z__[1], &c__1); - dscal_(n, &s, &z__[1], &c__1); - ynorm = s * ynorm; - -/* solve u*z = v */ - - i__1 = *n; - for (kb = 1; kb <= i__1; ++kb) { - k = *n + 1 - kb; - if ((d__1 = z__[k], abs(d__1)) <= (d__2 = a[k + k * a_dim1], abs(d__2) - )) { - goto L150; - } - s = (d__1 = a[k + k * a_dim1], abs(d__1)) / (d__2 = z__[k], abs(d__2)) - ; - dscal_(n, &s, &z__[1], &c__1); - ynorm = s * ynorm; -L150: - if (a[k + k * a_dim1] != 0.) { - z__[k] /= a[k + k * a_dim1]; - } - if (a[k + k * a_dim1] == 0.) { - z__[k] = 1.; - } - t = -z__[k]; - i__2 = k - 1; - daxpy_(&i__2, &t, &a[k * a_dim1 + 1], &c__1, &z__[1], &c__1); -/* L160: */ - } -/* make znorm = 1.0 */ - s = 1. / dasum_(n, &z__[1], &c__1); - dscal_(n, &s, &z__[1], &c__1); - ynorm = s * ynorm; - - if (anorm != 0.) { - *rcond = ynorm / anorm; - } - if (anorm == 0.) { - *rcond = 0.; - } - return 0; -} /* dgeco_ */ - -/* Subroutine */ int dgedi_(doublereal *a, integer *lda, integer *n, integer * - ipvt, doublereal *det, doublereal *work, integer *job) -{ - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2; - - /* Local variables */ - integer i__, j, k, l; - doublereal t; - integer kb, kp1, nm1; - doublereal ten; - extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, - integer *), dswap_(integer *, doublereal *, integer *, doublereal - *, integer *), daxpy_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - - -/* dgedi computes the determinant and inverse of a matrix */ -/* using the factors computed by dgeco or dgefa. */ - -/* on entry */ - -/* a double precision(lda, n) */ -/* the output from dgeco or dgefa. */ - -/* lda integer */ -/* the leading dimension of the array a . */ - -/* n integer */ -/* the order of the matrix a . */ - -/* ipvt integer(n) */ -/* the pivot vector from dgeco or dgefa. */ - -/* work double precision(n) */ -/* work vector. contents destroyed. */ - -/* job integer */ -/* = 11 both determinant and inverse. */ -/* = 01 inverse only. */ -/* = 10 determinant only. */ - -/* on return */ - -/* a inverse of original matrix if requested. */ -/* otherwise unchanged. */ - -/* det double precision(2) */ -/* determinant of original matrix if requested. */ -/* otherwise not referenced. */ -/* determinant = det(1) * 10.0**det(2) */ -/* with 1.0 .le. dabs(det(1)) .lt. 10.0 */ -/* or det(1) .eq. 0.0 . */ - -/* error condition */ - -/* a division by zero will occur if the input factor contains */ -/* a zero on the diagonal and the inverse is requested. */ -/* it will not occur if the subroutines are called correctly */ -/* and if dgeco has set rcond .gt. 0.0 or dgefa has set */ -/* info .eq. 0 . */ - -/* linpack. this version dated 08/14/78 . */ -/* cleve moler, university of new mexico, argonne national lab. */ - -/* subroutines and functions */ - -/* blas daxpy,dscal,dswap */ -/* fortran dabs,mod */ - -/* internal variables */ - - - -/* compute determinant */ - - /* Parameter adjustments */ - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipvt; - --det; - --work; - - /* Function Body */ - if (*job / 10 == 0) { - goto L70; - } - det[1] = 1.; - det[2] = 0.; - ten = 10.; - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (ipvt[i__] != i__) { - det[1] = -det[1]; - } - det[1] = a[i__ + i__ * a_dim1] * det[1]; -/* ...exit */ - if (det[1] == 0.) { - goto L60; - } -L10: - if (abs(det[1]) >= 1.) { - goto L20; - } - det[1] = ten * det[1]; - det[2] += -1.; - goto L10; -L20: -L30: - if (abs(det[1]) < ten) { - goto L40; - } - det[1] /= ten; - det[2] += 1.; - goto L30; -L40: -/* L50: */ - ; - } -L60: -L70: - -/* compute inverse(u) */ - - if (*job % 10 == 0) { - goto L150; - } - i__1 = *n; - for (k = 1; k <= i__1; ++k) { - a[k + k * a_dim1] = 1. / a[k + k * a_dim1]; - t = -a[k + k * a_dim1]; - i__2 = k - 1; - dscal_(&i__2, &t, &a[k * a_dim1 + 1], &c__1); - kp1 = k + 1; - if (*n < kp1) { - goto L90; - } - i__2 = *n; - for (j = kp1; j <= i__2; ++j) { - t = a[k + j * a_dim1]; - a[k + j * a_dim1] = 0.; - daxpy_(&k, &t, &a[k * a_dim1 + 1], &c__1, &a[j * a_dim1 + 1], & - c__1); -/* L80: */ - } -L90: -/* L100: */ - ; - } - -/* form inverse(u)*inverse(l) */ - - nm1 = *n - 1; - if (nm1 < 1) { - goto L140; - } - i__1 = nm1; - for (kb = 1; kb <= i__1; ++kb) { - k = *n - kb; - kp1 = k + 1; - i__2 = *n; - for (i__ = kp1; i__ <= i__2; ++i__) { - work[i__] = a[i__ + k * a_dim1]; - a[i__ + k * a_dim1] = 0.; -/* L110: */ - } - i__2 = *n; - for (j = kp1; j <= i__2; ++j) { - t = work[j]; - daxpy_(n, &t, &a[j * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & - c__1); -/* L120: */ - } - l = ipvt[k]; - if (l != k) { - dswap_(n, &a[k * a_dim1 + 1], &c__1, &a[l * a_dim1 + 1], &c__1); - } -/* L130: */ - } -L140: -L150: - return 0; -} /* dgedi_ */ - diff --git a/ext/f2c_math/polfit.c b/ext/f2c_math/polfit.c deleted file mode 100644 index 85ddb2018..000000000 --- a/ext/f2c_math/polfit.c +++ /dev/null @@ -1,404 +0,0 @@ -/* polfit.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* DECK POLFIT */ -/* Subroutine */ int polfit_(integer *n, real *x, real *y, real *w, integer * - maxdeg, integer *ndeg, real *eps, real *r__, integer *ierr, real *a) -{ - /* System generated locals */ - integer i__1; - real r__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, j, m, k1, k2, k3, k4, k5; - real w1, w11, xm, yp; - integer jp1; - real sig; - integer k1pj, k2pj, k4pi, k3pi, k5pi, mop1, nder; - real sigj; - integer jpas; - real temp, etst; - doublereal temd1, temd2; - integer nfail; - real sigjm1, sigpas; - extern /* Subroutine */ int pvalue_(integer *, integer *, real *, real *, - real *, real *); - -/* ***BEGIN PROLOGUE POLFIT */ -/* ***PURPOSE Fit discrete data in a least squares sense by polynomials */ -/* in one variable. */ -/* ***LIBRARY SLATEC */ -/* ***CATEGORY K1A1A2 */ -/* ***TYPE SINGLE PRECISION (POLFIT-S, DPOLFT-D) */ -/* ***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT */ -/* ***AUTHOR Shampine, L. F., (SNLA) */ -/* Davenport, S. M., (SNLA) */ -/* Huddleston, R. E., (SNLL) */ -/* ***DESCRIPTION */ - -/* Abstract */ - -/* Given a collection of points X(I) and a set of values Y(I) which */ -/* correspond to some function or measurement at each of the X(I), */ -/* subroutine POLFIT computes the weighted least-squares polynomial */ -/* fits of all degrees up to some degree either specified by the user */ -/* or determined by the routine. The fits thus obtained are in */ -/* orthogonal polynomial form. Subroutine PVALUE may then be */ -/* called to evaluate the fitted polynomials and any of their */ -/* derivatives at any point. The subroutine PCOEF may be used to */ -/* express the polynomial fits as powers of (X-C) for any specified */ -/* point C. */ - -/* The parameters for POLFIT are */ - -/* Input -- */ -/* N - the number of data points. The arrays X, Y and W */ -/* must be dimensioned at least N (N .GE. 1). */ -/* X - array of values of the independent variable. These */ -/* values may appear in any order and need not all be */ -/* distinct. */ -/* Y - array of corresponding function values. */ -/* W - array of positive values to be used as weights. If */ -/* W(1) is negative, POLFIT will set all the weights */ -/* to 1.0, which means unweighted least squares error */ -/* will be minimized. To minimize relative error, the */ -/* user should set the weights to: W(I) = 1.0/Y(I)**2, */ -/* I = 1,...,N . */ -/* MAXDEG - maximum degree to be allowed for polynomial fit. */ -/* MAXDEG may be any non-negative integer less than N. */ -/* Note -- MAXDEG cannot be equal to N-1 when a */ -/* statistical test is to be used for degree selection, */ -/* i.e., when input value of EPS is negative. */ -/* EPS - specifies the criterion to be used in determining */ -/* the degree of fit to be computed. */ -/* (1) If EPS is input negative, POLFIT chooses the */ -/* degree based on a statistical F test of */ -/* significance. One of three possible */ -/* significance levels will be used: .01, .05 or */ -/* .10. If EPS=-1.0 , the routine will */ -/* automatically select one of these levels based */ -/* on the number of data points and the maximum */ -/* degree to be considered. If EPS is input as */ -/* -.01, -.05, or -.10, a significance level of */ -/* .01, .05, or .10, respectively, will be used. */ -/* (2) If EPS is set to 0., POLFIT computes the */ -/* polynomials of degrees 0 through MAXDEG . */ -/* (3) If EPS is input positive, EPS is the RMS */ -/* error tolerance which must be satisfied by the */ -/* fitted polynomial. POLFIT will increase the */ -/* degree of fit until this criterion is met or */ -/* until the maximum degree is reached. */ - -/* Output -- */ -/* NDEG - degree of the highest degree fit computed. */ -/* EPS - RMS error of the polynomial of degree NDEG . */ -/* R - vector of dimension at least NDEG containing values */ -/* of the fit of degree NDEG at each of the X(I) . */ -/* Except when the statistical test is used, these */ -/* values are more accurate than results from subroutine */ -/* PVALUE normally are. */ -/* IERR - error flag with the following possible values. */ -/* 1 -- indicates normal execution, i.e., either */ -/* (1) the input value of EPS was negative, and the */ -/* computed polynomial fit of degree NDEG */ -/* satisfies the specified F test, or */ -/* (2) the input value of EPS was 0., and the fits of */ -/* all degrees up to MAXDEG are complete, or */ -/* (3) the input value of EPS was positive, and the */ -/* polynomial of degree NDEG satisfies the RMS */ -/* error requirement. */ -/* 2 -- invalid input parameter. At least one of the input */ -/* parameters has an illegal value and must be corrected */ -/* before POLFIT can proceed. Valid input results */ -/* when the following restrictions are observed */ -/* N .GE. 1 */ -/* 0 .LE. MAXDEG .LE. N-1 for EPS .GE. 0. */ -/* 0 .LE. MAXDEG .LE. N-2 for EPS .LT. 0. */ -/* W(1)=-1.0 or W(I) .GT. 0., I=1,...,N . */ -/* 3 -- cannot satisfy the RMS error requirement with a */ -/* polynomial of degree no greater than MAXDEG . Best */ -/* fit found is of degree MAXDEG . */ -/* 4 -- cannot satisfy the test for significance using */ -/* current value of MAXDEG . Statistically, the */ -/* best fit found is of order NORD . (In this case, */ -/* NDEG will have one of the values: MAXDEG-2, */ -/* MAXDEG-1, or MAXDEG). Using a higher value of */ -/* MAXDEG may result in passing the test. */ -/* A - work and output array having at least 3N+3MAXDEG+3 */ -/* locations */ - -/* Note - POLFIT calculates all fits of degrees up to and including */ -/* NDEG . Any or all of these fits can be evaluated or */ -/* expressed as powers of (X-C) using PVALUE and PCOEF */ -/* after just one call to POLFIT . */ - -/* ***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, */ -/* Curve fitting by polynomials in one variable, Report */ -/* SLA-74-0270, Sandia Laboratories, June 1974. */ -/* ***ROUTINES CALLED PVALUE, XERMSG */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 740601 DATE WRITTEN */ -/* 890531 Changed all specific intrinsics to generic. (WRB) */ -/* 890531 REVISION DATE from Version 3.2 */ -/* 891214 Prologue converted to Version 4.0 format. (BAB) */ -/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */ -/* 920501 Reformatted the REFERENCES section. (WRB) */ -/* 920527 Corrected erroneous statements in DESCRIPTION. (WRB) */ -/* ***END PROLOGUE POLFIT */ -/* DIMENSION CO(4,3) */ -/* SAVE CO */ -/* DATA CO(1,1), CO(2,1), CO(3,1), CO(4,1), CO(1,2), CO(2,2), */ -/* 1 CO(3,2), CO(4,2), CO(1,3), CO(2,3), CO(3,3), */ -/* 2 CO(4,3)/-13.086850,-2.4648165,-3.3846535,-1.2973162, */ -/* 3 -3.3381146,-1.7812271,-3.2578406,-1.6589279, */ -/* 4 -1.6282703,-1.3152745,-3.2640179,-1.9829776/ */ -/* ***FIRST EXECUTABLE STATEMENT POLFIT */ - /* Parameter adjustments */ - --a; - --r__; - --w; - --y; - --x; - - /* Uninitialized local variables -> note, I don't see how this - * function can be working */ - k1=0; - k2 = 0; - k3 = 0; - k4 = 0; - k5 = 0; - etst = 1.0E-13f; - xm = 1.0; - - /* Function Body */ - m = abs(*n); - if (m == 0) { - goto L30; - } - if (*maxdeg < 0) { - goto L30; - } - a[1] = (real) (*maxdeg); - mop1 = *maxdeg + 1; - if (m < mop1) { - goto L30; - } - if (*eps < 0.f && m == mop1) { - goto L30; - } - j = 0; - -/* SEE IF POLYNOMIAL OF DEGREE 0 SATISFIES THE DEGREE SELECTION CRITERION */ - - if (*eps < 0.f) { - goto L24; - } else if (*eps == 0) { - goto L26; - } else { - goto L27; - } - -/* INCREMENT DEGREE */ - -L16: - ++j; - jp1 = j + 1; - k1pj = k1 + j; - k2pj = k2 + j; - sigjm1 = sigj; - -/* COMPUTE NEW B COEFFICIENT EXCEPT WHEN J = 1 */ - - if (j > 1) { - a[k1pj] = w11 / w1; - } - -/* COMPUTE NEW A COEFFICIENT */ - - temd1 = 0.; - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - k4pi = k4 + i__; - temd2 = a[k4pi]; - temd1 += (doublereal) x[i__] * (doublereal) w[i__] * temd2 * temd2; -/* L18: */ - } - a[jp1] = (real) (temd1 / w11); - -/* EVALUATE ORTHOGONAL POLYNOMIAL AT DATA POINTS */ - - w1 = w11; - w11 = 0.f; - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - k3pi = k3 + i__; - k4pi = k4 + i__; - temp = a[k3pi]; - a[k3pi] = a[k4pi]; - a[k4pi] = (x[i__] - a[jp1]) * a[k3pi] - a[k1pj] * temp; -/* L19: */ -/* Computing 2nd power */ - r__1 = a[k4pi]; - w11 += w[i__] * (r__1 * r__1); - } - -/* GET NEW ORTHOGONAL POLYNOMIAL COEFFICIENT USING PARTIAL DOUBLE */ -/* PRECISION */ - - temd1 = 0.; - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - k4pi = k4 + i__; - k5pi = k5 + i__; - temd2 = (doublereal) w[i__] * (doublereal) (y[i__] - r__[i__] - a[ - k5pi]) * (doublereal) a[k4pi]; -/* L20: */ - temd1 += temd2; - } - temd1 /= (doublereal) w11; - a[k2pj + 1] = (real) temd1; - -/* UPDATE POLYNOMIAL EVALUATIONS AT EACH OF THE DATA POINTS, AND */ -/* ACCUMULATE SUM OF SQUARES OF ERRORS. THE POLYNOMIAL EVALUATIONS ARE */ -/* COMPUTED AND STORED IN EXTENDED PRECISION. FOR THE I-TH DATA POINT, */ -/* THE MOST SIGNIFICANT BITS ARE STORED IN R(I) , AND THE LEAST */ -/* SIGNIFICANT BITS ARE IN A(K5PI) . */ - - sigj = 0.f; - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - k4pi = k4 + i__; - k5pi = k5 + i__; - temd2 = (doublereal) r__[i__] + (doublereal) a[k5pi] + temd1 * ( - doublereal) a[k4pi]; - r__[i__] = (real) temd2; - a[k5pi] = (real) (temd2 - r__[i__]); -/* L21: */ -/* Computing 2nd power */ - r__1 = y[i__] - r__[i__] - a[k5pi]; - sigj += w[i__] * (r__1 * r__1); - } - -/* SEE IF DEGREE SELECTION CRITERION HAS BEEN SATISFIED OR IF DEGREE */ -/* MAXDEG HAS BEEN REACHED */ - - if (*eps < 0.f) { - goto L23; - } else if (*eps == 0) { - goto L26; - } else { - goto L27; - } - -/* COMPUTE F STATISTICS (INPUT EPS .LT. 0.) */ - -L23: - if (sigj == 0.f) { - goto L29; - } -/* DEGF = M - J - 1 */ -/* DEN = (CO(4,KSIG)*DEGF + 1.0)*DEGF */ -/* FCRIT = (((CO(3,KSIG)*DEGF) + CO(2,KSIG))*DEGF + CO(1,KSIG))/DEN */ -/* FCRIT = FCRIT*FCRIT */ -/* F = (SIGJM1 - SIGJ)*DEGF/SIGJ */ -/* IF (F .LT. FCRIT) GO TO 25 */ - -/* POLYNOMIAL OF DEGREE J SATISFIES F TEST */ - -L24: - sigpas = sigj; - jpas = j; - nfail = 0; - if (*maxdeg == j) { - goto L32; - } - goto L16; - -/* POLYNOMIAL OF DEGREE J FAILS F TEST. IF THERE HAVE BEEN THREE */ -/* SUCCESSIVE FAILURES, A STATISTICALLY BEST DEGREE HAS BEEN FOUND. */ - -/* L25: */ - ++nfail; - if (nfail >= 3) { - goto L29; - } - if (*maxdeg == j) { - goto L32; - } - goto L16; - -/* RAISE THE DEGREE IF DEGREE MAXDEG HAS NOT YET BEEN REACHED (INPUT */ -/* EPS = 0.) */ - -L26: - if (*maxdeg == j) { - goto L28; - } - goto L16; - -/* SEE IF RMS ERROR CRITERION IS SATISFIED (INPUT EPS .GT. 0.) */ - -L27: - if (sigj <= etst) { - goto L28; - } - if (*maxdeg == j) { - goto L31; - } - goto L16; - -/* RETURNS */ - -L28: - *ierr = 1; - *ndeg = j; - sig = sigj; - goto L33; -L29: - *ierr = 1; - *ndeg = jpas; - sig = sigpas; - goto L33; -L30: - *ierr = 2; -/* CALL XERMSG ('SLATEC', 'POLFIT', 'INVALID INPUT PARAMETER.', 2, */ -/* + 1) */ - goto L37; -L31: - *ierr = 3; - *ndeg = *maxdeg; - sig = sigj; - goto L33; -L32: - *ierr = 4; - *ndeg = jpas; - sig = sigpas; - -L33: - a[k3] = (real) (*ndeg); - -/* WHEN STATISTICAL TEST HAS BEEN USED, EVALUATE THE BEST POLYNOMIAL AT */ -/* ALL THE DATA POINTS IF R DOES NOT ALREADY CONTAIN THESE VALUES */ - - if (*eps >= 0.f || *ndeg == *maxdeg) { - goto L36; - } - nder = 0; - i__1 = m; - for (i__ = 1; i__ <= i__1; ++i__) { - pvalue_(ndeg, &nder, &x[i__], &r__[i__], &yp, &a[1]); -/* L35: */ - } -L36: - *eps = (real) sqrt(sig / xm); -L37: - return 0; -} /* polfit_ */ - diff --git a/ext/f2c_math/printstring.c b/ext/f2c_math/printstring.c deleted file mode 100644 index bf21cc412..000000000 --- a/ext/f2c_math/printstring.c +++ /dev/null @@ -1,5 +0,0 @@ -#include - -void printstring_(char* s) { - printf("%s",s); -} diff --git a/ext/f2c_math/pvalue.c b/ext/f2c_math/pvalue.c deleted file mode 100644 index cab59d9d3..000000000 --- a/ext/f2c_math/pvalue.c +++ /dev/null @@ -1,211 +0,0 @@ -/* pvalue.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* DECK PVALUE */ -/* Subroutine */ int pvalue_(integer *l, integer *nder, real *x, real *yfit, - real *yp, real *a) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Local variables */ - integer i__, n, k1, k2, k3, k4; - real cc; - integer ic, kc, in, k1i, lm1, lp1; - real dif; - integer k3p1, k4p1, ndo; - real val; - integer ilo, iup, ndp1, inp1, k3pn, k4pn, nord, maxord; - -/* ***BEGIN PROLOGUE PVALUE */ -/* ***PURPOSE Use the coefficients generated by POLFIT to evaluate the */ -/* polynomial fit of degree L, along with the first NDER of */ -/* its derivatives, at a specified point. */ -/* ***LIBRARY SLATEC */ -/* ***CATEGORY K6 */ -/* ***TYPE SINGLE PRECISION (PVALUE-S, DP1VLU-D) */ -/* ***KEYWORDS CURVE FITTING, LEAST SQUARES, POLYNOMIAL APPROXIMATION */ -/* ***AUTHOR Shampine, L. F., (SNLA) */ -/* Davenport, S. M., (SNLA) */ -/* ***DESCRIPTION */ - -/* Written by L. F. Shampine and S. M. Davenport. */ - -/* Abstract */ - -/* The subroutine PVALUE uses the coefficients generated by POLFIT */ -/* to evaluate the polynomial fit of degree L , along with the first */ -/* NDER of its derivatives, at a specified point. Computationally */ -/* stable recurrence relations are used to perform this task. */ - -/* The parameters for PVALUE are */ - -/* Input -- */ -/* L - the degree of polynomial to be evaluated. L may be */ -/* any non-negative integer which is less than or equal */ -/* to NDEG , the highest degree polynomial provided */ -/* by POLFIT . */ -/* NDER - the number of derivatives to be evaluated. NDER */ -/* may be 0 or any positive value. If NDER is less */ -/* than 0, it will be treated as 0. */ -/* X - the argument at which the polynomial and its */ -/* derivatives are to be evaluated. */ -/* A - work and output array containing values from last */ -/* call to POLFIT . */ - -/* Output -- */ -/* YFIT - value of the fitting polynomial of degree L at X */ -/* YP - array containing the first through NDER derivatives */ -/* of the polynomial of degree L . YP must be */ -/* dimensioned at least NDER in the calling program. */ - -/* ***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, */ -/* Curve fitting by polynomials in one variable, Report */ -/* SLA-74-0270, Sandia Laboratories, June 1974. */ -/* ***ROUTINES CALLED XERMSG */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 740601 DATE WRITTEN */ -/* 890531 Changed all specific intrinsics to generic. (WRB) */ -/* 890531 REVISION DATE from Version 3.2 */ -/* 891214 Prologue converted to Version 4.0 format. (BAB) */ -/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */ -/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */ -/* 920501 Reformatted the REFERENCES section. (WRB) */ -/* ***END PROLOGUE PVALUE */ -/* ***FIRST EXECUTABLE STATEMENT PVALUE */ - /* Parameter adjustments */ - --a; - --yp; - - /* Function Body */ - if (*l < 0) { - goto L12; - } - ndo = max(*nder,0); - ndo = min(ndo,*l); - maxord = (integer) (a[1] + .5f); - k1 = maxord + 1; - k2 = k1 + maxord; - k3 = k2 + maxord + 2; - nord = (integer) (a[k3] + .5f); - if (*l > nord) { - goto L11; - } - k4 = k3 + *l + 1; - if (*nder < 1) { - goto L2; - } - i__1 = *nder; - for (i__ = 1; i__ <= i__1; ++i__) { -/* L1: */ - yp[i__] = 0.f; - } -L2: - if (*l >= 2) { - goto L4; - } - if (*l == 1) { - goto L3; - } - -/* L IS 0 */ - - val = a[k2 + 1]; - goto L10; - -/* L IS 1 */ - -L3: - cc = a[k2 + 2]; - val = a[k2 + 1] + (*x - a[2]) * cc; - if (*nder >= 1) { - yp[1] = cc; - } - goto L10; - -/* L IS GREATER THAN 1 */ - -L4: - ndp1 = ndo + 1; - k3p1 = k3 + 1; - k4p1 = k4 + 1; - lp1 = *l + 1; - lm1 = *l - 1; - ilo = k3 + 3; - iup = k4 + ndp1; - i__1 = iup; - for (i__ = ilo; i__ <= i__1; ++i__) { -/* L5: */ - a[i__] = 0.f; - } - dif = *x - a[lp1]; - kc = k2 + lp1; - a[k4p1] = a[kc]; - a[k3p1] = a[kc - 1] + dif * a[k4p1]; - a[k3 + 2] = a[k4p1]; - -/* EVALUATE RECURRENCE RELATIONS FOR FUNCTION VALUE AND DERIVATIVES */ - - i__1 = lm1; - for (i__ = 1; i__ <= i__1; ++i__) { - in = *l - i__; - inp1 = in + 1; - k1i = k1 + inp1; - ic = k2 + in; - dif = *x - a[inp1]; - val = a[ic] + dif * a[k3p1] - a[k1i] * a[k4p1]; - if (ndo <= 0) { - goto L8; - } - i__2 = ndo; - for (n = 1; n <= i__2; ++n) { - k3pn = k3p1 + n; - k4pn = k4p1 + n; -/* L6: */ - yp[n] = dif * a[k3pn] + n * a[k3pn - 1] - a[k1i] * a[k4pn]; - } - -/* SAVE VALUES NEEDED FOR NEXT EVALUATION OF RECURRENCE RELATIONS */ - - i__2 = ndo; - for (n = 1; n <= i__2; ++n) { - k3pn = k3p1 + n; - k4pn = k4p1 + n; - a[k4pn] = a[k3pn]; -/* L7: */ - a[k3pn] = yp[n]; - } -L8: - a[k4p1] = a[k3p1]; -/* L9: */ - a[k3p1] = val; - } - -/* NORMAL RETURN OR ABORT DUE TO ERROR */ - -L10: - *yfit = val; - return 0; - -L11: - return 0; -/* WRITE (XERN1, '(I8)') L */ -/* WRITE (XERN2, '(I8)') NORD */ -/* CALL XERMSG ('SLATEC', 'PVALUE', */ -/* * 'THE ORDER OF POLYNOMIAL EVALUATION, L = ' // XERN1 // */ -/* * ' REQUESTED EXCEEDS THE HIGHEST ORDER FIT, NORD = ' // XERN2 // */ -/* * ', COMPUTED BY POLFIT -- EXECUTION TERMINATED.', 8, 2) */ -/* RETURN */ - -L12: - return 0; -/* CALL XERMSG ('SLATEC', 'PVALUE', */ -/* + 'INVALID INPUT PARAMETER. ORDER OF POLYNOMIAL EVALUATION ' // */ -/* + 'REQUESTED IS NEGATIVE -- EXECUTION TERMINATED.', 2, 2) */ -/* RETURN */ -} /* pvalue_ */ - diff --git a/ext/f2c_math/xercnt.c b/ext/f2c_math/xercnt.c deleted file mode 100644 index 488d6074e..000000000 --- a/ext/f2c_math/xercnt.c +++ /dev/null @@ -1,70 +0,0 @@ -/* xercnt.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* DECK XERCNT */ -/* Subroutine */ int xercnt_(char *librar, char *subrou, char *messg, integer - *nerr, integer *level, integer *kontrl, ftnlen librar_len, ftnlen - subrou_len, ftnlen messg_len) -{ -/* ***BEGIN PROLOGUE XERCNT */ -/* ***SUBSIDIARY */ -/* ***PURPOSE Allow user control over handling of errors. */ -/* ***LIBRARY SLATEC (XERROR) */ -/* ***CATEGORY R3C */ -/* ***TYPE ALL (XERCNT-A) */ -/* ***KEYWORDS ERROR, XERROR */ -/* ***AUTHOR Jones, R. E., (SNLA) */ -/* ***DESCRIPTION */ - -/* Abstract */ -/* Allows user control over handling of individual errors. */ -/* Just after each message is recorded, but before it is */ -/* processed any further (i.e., before it is printed or */ -/* a decision to abort is made), a call is made to XERCNT. */ -/* If the user has provided his own version of XERCNT, he */ -/* can then override the value of KONTROL used in processing */ -/* this message by redefining its value. */ -/* KONTRL may be set to any value from -2 to 2. */ -/* The meanings for KONTRL are the same as in XSETF, except */ -/* that the value of KONTRL changes only for this message. */ -/* If KONTRL is set to a value outside the range from -2 to 2, */ -/* it will be moved back into that range. */ - -/* Description of Parameters */ - -/* --Input-- */ -/* LIBRAR - the library that the routine is in. */ -/* SUBROU - the subroutine that XERMSG is being called from */ -/* MESSG - the first 20 characters of the error message. */ -/* NERR - same as in the call to XERMSG. */ -/* LEVEL - same as in the call to XERMSG. */ -/* KONTRL - the current value of the control flag as set */ -/* by a call to XSETF. */ - -/* --Output-- */ -/* KONTRL - the new value of KONTRL. If KONTRL is not */ -/* defined, it will remain at its original value. */ -/* This changed value of control affects only */ -/* the current occurrence of the current message. */ - -/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ -/* Error-handling Package, SAND82-0800, Sandia */ -/* Laboratories, 1982. */ -/* ***ROUTINES CALLED (NONE) */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 790801 DATE WRITTEN */ -/* 861211 REVISION DATE from Version 3.2 */ -/* 891214 Prologue converted to Version 4.0 format. (BAB) */ -/* 900206 Routine changed from user-callable to subsidiary. (WRB) */ -/* 900510 Changed calling sequence to include LIBRARY and SUBROUTINE */ -/* names, changed routine name from XERCTL to XERCNT. (RWC) */ -/* 920501 Reformatted the REFERENCES section. (WRB) */ -/* ***END PROLOGUE XERCNT */ -/* ***FIRST EXECUTABLE STATEMENT XERCNT */ - return 0; -} /* xercnt_ */ - diff --git a/ext/f2c_math/xerhlt.c b/ext/f2c_math/xerhlt.c deleted file mode 100644 index 6d1875aab..000000000 --- a/ext/f2c_math/xerhlt.c +++ /dev/null @@ -1,65 +0,0 @@ -/* xerhlt.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__9 = 9; -static integer c__1 = 1; - -/* DECK XERHLT */ -/* Subroutine */ int xerhlt_(char *messg, ftnlen messg_len) -{ - /* Builtin functions */ - integer s_wsle(cilist *), do_lio(integer *, integer *, char *, ftnlen), - e_wsle(void); - /* Subroutine */ int s_stop(char *, ftnlen); - - /* Fortran I/O blocks */ - static cilist io___1 = { 0, 6, 0, 0, 0 }; - - -/* ***BEGIN PROLOGUE XERHLT */ -/* ***SUBSIDIARY */ -/* ***PURPOSE Abort program execution and print error message. */ -/* ***LIBRARY SLATEC (XERROR) */ -/* ***CATEGORY R3C */ -/* ***TYPE ALL (XERHLT-A) */ -/* ***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR */ -/* ***AUTHOR Jones, R. E., (SNLA) */ -/* ***DESCRIPTION */ - -/* Abstract */ -/* ***Note*** machine dependent routine */ -/* XERHLT aborts the execution of the program. */ -/* The error message causing the abort is given in the calling */ -/* sequence, in case one needs it for printing on a dayfile, */ -/* for example. */ - -/* Description of Parameters */ -/* MESSG is as in XERMSG. */ - -/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ -/* Error-handling Package, SAND82-0800, Sandia */ -/* Laboratories, 1982. */ -/* ***ROUTINES CALLED (NONE) */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 790801 DATE WRITTEN */ -/* 861211 REVISION DATE from Version 3.2 */ -/* 891214 Prologue converted to Version 4.0 format. (BAB) */ -/* 900206 Routine changed from user-callable to subsidiary. (WRB) */ -/* 900510 Changed calling sequence to delete length of character */ -/* and changed routine name from XERABT to XERHLT. (RWC) */ -/* 920501 Reformatted the REFERENCES section. (WRB) */ -/* ***END PROLOGUE XERHLT */ -/* ***FIRST EXECUTABLE STATEMENT XERHLT */ - s_wsle(&io___1); - do_lio(&c__9, &c__1, "stopping...", (ftnlen)11); - e_wsle(); - s_stop("", (ftnlen)0); - return 0; -} /* xerhlt_ */ - diff --git a/ext/f2c_math/xermsg.c b/ext/f2c_math/xermsg.c deleted file mode 100644 index 2f23e5844..000000000 --- a/ext/f2c_math/xermsg.c +++ /dev/null @@ -1,464 +0,0 @@ -/* xermsg.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__2 = 2; -static integer c__0 = 0; -static logical c_false = FALSE_; -static integer c__4 = 4; -static integer c_n1 = -1; -static integer c__72 = 72; -static integer c__1 = 1; -static logical c_true = TRUE_; - -/* DECK XERMSG */ -/* Subroutine */ int xermsg_(char *librar, char *subrou, char *messg, integer - *nerr, integer *level, ftnlen librar_len, ftnlen subrou_len, ftnlen - messg_len) -{ - /* System generated locals */ - address a__1[2]; - integer i__1, i__2, i__3[2]; - char ch__1[87]; - icilist ici__1; - - /* Builtin functions */ - /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); - integer i_len(char *, ftnlen), s_wsfi(icilist *), do_fio(integer *, char * - , ftnlen), e_wsfi(void); - /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); - - /* Local variables */ - integer i__, lerr; - char temp[72]; - extern /* Subroutine */ int fdump_(void); - char xlibr[8]; - integer ltemp, kount; - char xsubr[8]; - extern integer j4save_(integer *, integer *, logical *); - integer llevel, maxmes; - char lfirst[20]; - extern /* Subroutine */ int xercnt_(char *, char *, char *, integer *, - integer *, integer *, ftnlen, ftnlen, ftnlen); - integer lkntrl, kdummy; - extern /* Subroutine */ int xerhlt_(char *, ftnlen); - integer mkntrl; - extern /* Subroutine */ int xersve_(char *, char *, char *, integer *, - integer *, integer *, integer *, ftnlen, ftnlen, ftnlen), xerprn_( - char *, integer *, char *, integer *, ftnlen, ftnlen); - -/* ***BEGIN PROLOGUE XERMSG */ -/* ***PURPOSE Process error messages for SLATEC and other libraries. */ -/* ***LIBRARY SLATEC (XERROR) */ -/* ***CATEGORY R3C */ -/* ***TYPE ALL (XERMSG-A) */ -/* ***KEYWORDS ERROR MESSAGE, XERROR */ -/* ***AUTHOR Fong, Kirby, (NMFECC at LLNL) */ -/* ***DESCRIPTION */ - -/* XERMSG processes a diagnostic message in a manner determined by the */ -/* value of LEVEL and the current value of the library error control */ -/* flag, KONTRL. See subroutine XSETF for details. */ - -/* LIBRAR A character constant (or character variable) with the name */ -/* of the library. This will be 'SLATEC' for the SLATEC */ -/* Common Math Library. The error handling package is */ -/* general enough to be used by many libraries */ -/* simultaneously, so it is desirable for the routine that */ -/* detects and reports an error to identify the library name */ -/* as well as the routine name. */ - -/* SUBROU A character constant (or character variable) with the name */ -/* of the routine that detected the error. Usually it is the */ -/* name of the routine that is calling XERMSG. There are */ -/* some instances where a user callable library routine calls */ -/* lower level subsidiary routines where the error is */ -/* detected. In such cases it may be more informative to */ -/* supply the name of the routine the user called rather than */ -/* the name of the subsidiary routine that detected the */ -/* error. */ - -/* MESSG A character constant (or character variable) with the text */ -/* of the error or warning message. In the example below, */ -/* the message is a character constant that contains a */ -/* generic message. */ - -/* CALL XERMSG ('SLATEC', 'MMPY', */ -/* *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', */ -/* *3, 1) */ - -/* It is possible (and is sometimes desirable) to generate a */ -/* specific message--e.g., one that contains actual numeric */ -/* values. Specific numeric values can be converted into */ -/* character strings using formatted WRITE statements into */ -/* character variables. This is called standard Fortran */ -/* internal file I/O and is exemplified in the first three */ -/* lines of the following example. You can also catenate */ -/* substrings of characters to construct the error message. */ -/* Here is an example showing the use of both writing to */ -/* an internal file and catenating character strings. */ - -/* CHARACTER*5 CHARN, CHARL */ -/* WRITE (CHARN,10) N */ -/* WRITE (CHARL,10) LDA */ -/* 10 FORMAT(I5) */ -/* CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// */ -/* * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// */ -/* * CHARL, 3, 1) */ - -/* There are two subtleties worth mentioning. One is that */ -/* the // for character catenation is used to construct the */ -/* error message so that no single character constant is */ -/* continued to the next line. This avoids confusion as to */ -/* whether there are trailing blanks at the end of the line. */ -/* The second is that by catenating the parts of the message */ -/* as an actual argument rather than encoding the entire */ -/* message into one large character variable, we avoid */ -/* having to know how long the message will be in order to */ -/* declare an adequate length for that large character */ -/* variable. XERMSG calls XERPRN to print the message using */ -/* multiple lines if necessary. If the message is very long, */ -/* XERPRN will break it into pieces of 72 characters (as */ -/* requested by XERMSG) for printing on multiple lines. */ -/* Also, XERMSG asks XERPRN to prefix each line with ' * ' */ -/* so that the total line length could be 76 characters. */ -/* Note also that XERPRN scans the error message backwards */ -/* to ignore trailing blanks. Another feature is that */ -/* the substring '$$' is treated as a new line sentinel */ -/* by XERPRN. If you want to construct a multiline */ -/* message without having to count out multiples of 72 */ -/* characters, just use '$$' as a separator. '$$' */ -/* obviously must occur within 72 characters of the */ -/* start of each line to have its intended effect since */ -/* XERPRN is asked to wrap around at 72 characters in */ -/* addition to looking for '$$'. */ - -/* NERR An integer value that is chosen by the library routine's */ -/* author. It must be in the range -99 to 999 (three */ -/* printable digits). Each distinct error should have its */ -/* own error number. These error numbers should be described */ -/* in the machine readable documentation for the routine. */ -/* The error numbers need be unique only within each routine, */ -/* so it is reasonable for each routine to start enumerating */ -/* errors from 1 and proceeding to the next integer. */ - -/* LEVEL An integer value in the range 0 to 2 that indicates the */ -/* level (severity) of the error. Their meanings are */ - -/* -1 A warning message. This is used if it is not clear */ -/* that there really is an error, but the user's attention */ -/* may be needed. An attempt is made to only print this */ -/* message once. */ - -/* 0 A warning message. This is used if it is not clear */ -/* that there really is an error, but the user's attention */ -/* may be needed. */ - -/* 1 A recoverable error. This is used even if the error is */ -/* so serious that the routine cannot return any useful */ -/* answer. If the user has told the error package to */ -/* return after recoverable errors, then XERMSG will */ -/* return to the Library routine which can then return to */ -/* the user's routine. The user may also permit the error */ -/* package to terminate the program upon encountering a */ -/* recoverable error. */ - -/* 2 A fatal error. XERMSG will not return to its caller */ -/* after it receives a fatal error. This level should */ -/* hardly ever be used; it is much better to allow the */ -/* user a chance to recover. An example of one of the few */ -/* cases in which it is permissible to declare a level 2 */ -/* error is a reverse communication Library routine that */ -/* is likely to be called repeatedly until it integrates */ -/* across some interval. If there is a serious error in */ -/* the input such that another step cannot be taken and */ -/* the Library routine is called again without the input */ -/* error having been corrected by the caller, the Library */ -/* routine will probably be called forever with improper */ -/* input. In this case, it is reasonable to declare the */ -/* error to be fatal. */ - -/* Each of the arguments to XERMSG is input; none will be modified by */ -/* XERMSG. A routine may make multiple calls to XERMSG with warning */ -/* level messages; however, after a call to XERMSG with a recoverable */ -/* error, the routine should return to the user. Do not try to call */ -/* XERMSG with a second recoverable error after the first recoverable */ -/* error because the error package saves the error number. The user */ -/* can retrieve this error number by calling another entry point in */ -/* the error handling package and then clear the error number when */ -/* recovering from the error. Calling XERMSG in succession causes the */ -/* old error number to be overwritten by the latest error number. */ -/* This is considered harmless for error numbers associated with */ -/* warning messages but must not be done for error numbers of serious */ -/* errors. After a call to XERMSG with a recoverable error, the user */ -/* must be given a chance to call NUMXER or XERCLR to retrieve or */ -/* clear the error number. */ -/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ -/* Error-handling Package, SAND82-0800, Sandia */ -/* Laboratories, 1982. */ -/* ***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 880101 DATE WRITTEN */ -/* 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. */ -/* THERE ARE TWO BASIC CHANGES. */ -/* 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO */ -/* PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES */ -/* INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS */ -/* ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE */ -/* ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER */ -/* ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY */ -/* 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE */ -/* LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. */ -/* 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE */ -/* FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE */ -/* OF LOWER CASE. */ -/* 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. */ -/* THE PRINCIPAL CHANGES ARE */ -/* 1. CLARIFY COMMENTS IN THE PROLOGUES */ -/* 2. RENAME XRPRNT TO XERPRN */ -/* 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES */ -/* SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / */ -/* CHARACTER FOR NEW RECORDS. */ -/* 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO */ -/* CLEAN UP THE CODING. */ -/* 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN */ -/* PREFIX. */ -/* 891013 REVISED TO CORRECT COMMENTS. */ -/* 891214 Prologue converted to Version 4.0 format. (WRB) */ -/* 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but */ -/* NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added */ -/* LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and */ -/* XERCTL to XERCNT. (RWC) */ -/* 920501 Reformatted the REFERENCES section. (WRB) */ -/* ***END PROLOGUE XERMSG */ -/* ***FIRST EXECUTABLE STATEMENT XERMSG */ - lkntrl = j4save_(&c__2, &c__0, &c_false); - maxmes = j4save_(&c__4, &c__0, &c_false); - -/* LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. */ -/* MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE */ -/* SHOULD BE PRINTED. */ - -/* WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN */ -/* CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, */ -/* AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. */ - - if (*nerr < -9999999 || *nerr > 99999999 || *nerr == 0 || *level < -1 || * - level > 2) { - xerprn_(" ***", &c_n1, "FATAL ERROR IN...$$ XERMSG -- INVALID ERROR " - "NUMBER OR LEVEL$$ JOB ABORT DUE TO FATAL ERROR.", &c__72, ( - ftnlen)4, (ftnlen)91); - xersve_(" ", " ", " ", &c__0, &c__0, &c__0, &kdummy, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); - xerhlt_(" ***XERMSG -- INVALID INPUT", (ftnlen)27); - return 0; - } - -/* RECORD THE MESSAGE. */ - - i__ = j4save_(&c__1, nerr, &c_true); - xersve_(librar, subrou, messg, &c__1, nerr, level, &kount, librar_len, - subrou_len, messg_len); - -/* HANDLE PRINT-ONCE WARNING MESSAGES. */ - - if (*level == -1 && kount > 1) { - return 0; - } - -/* ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. */ - - s_copy(xlibr, librar, (ftnlen)8, librar_len); - s_copy(xsubr, subrou, (ftnlen)8, subrou_len); - s_copy(lfirst, messg, (ftnlen)20, messg_len); - lerr = *nerr; - llevel = *level; - xercnt_(xlibr, xsubr, lfirst, &lerr, &llevel, &lkntrl, (ftnlen)8, (ftnlen) - 8, (ftnlen)20); - -/* Computing MAX */ - i__1 = -2, i__2 = min(2,lkntrl); - lkntrl = max(i__1,i__2); - mkntrl = abs(lkntrl); - -/* SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS */ -/* ZERO AND THE ERROR IS NOT FATAL. */ - - if (*level < 2 && lkntrl == 0) { - goto L30; - } - if (*level == 0 && kount > maxmes) { - goto L30; - } - if (*level == 1 && kount > maxmes && mkntrl == 1) { - goto L30; - } - if (*level == 2 && kount > max(1,maxmes)) { - goto L30; - } - -/* ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A */ -/* MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) */ -/* AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG */ -/* IS NOT ZERO. */ - - if (lkntrl != 0) { - s_copy(temp, "MESSAGE FROM ROUTINE ", (ftnlen)21, (ftnlen)21); -/* Computing MIN */ - i__1 = i_len(subrou, subrou_len); - i__ = min(i__1,16); - s_copy(temp + 21, subrou, i__, i__); - i__1 = i__ + 21; - s_copy(temp + i__1, " IN LIBRARY ", i__ + 33 - i__1, (ftnlen)12); - ltemp = i__ + 33; -/* Computing MIN */ - i__1 = i_len(librar, librar_len); - i__ = min(i__1,16); - i__1 = ltemp; - s_copy(temp + i__1, librar, ltemp + i__ - i__1, i__); - i__1 = ltemp + i__; - s_copy(temp + i__1, ".", ltemp + i__ + 1 - i__1, (ftnlen)1); - ltemp = ltemp + i__ + 1; - xerprn_(" ***", &c_n1, temp, &c__72, (ftnlen)4, ltemp); - } - -/* IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE */ -/* PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE */ -/* FROM EACH OF THE FOLLOWING THREE OPTIONS. */ -/* 1. LEVEL OF THE MESSAGE */ -/* 'INFORMATIVE MESSAGE' */ -/* 'POTENTIALLY RECOVERABLE ERROR' */ -/* 'FATAL ERROR' */ -/* 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE */ -/* 'PROG CONTINUES' */ -/* 'PROG ABORTED' */ -/* 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK */ -/* MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS */ -/* WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) */ -/* 'TRACEBACK REQUESTED' */ -/* 'TRACEBACK NOT REQUESTED' */ -/* NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT */ -/* EXCEED 74 CHARACTERS. */ -/* WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. */ - - if (lkntrl > 0) { - -/* THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. */ - - if (*level <= 0) { - s_copy(temp, "INFORMATIVE MESSAGE,", (ftnlen)20, (ftnlen)20); - ltemp = 20; - } else if (*level == 1) { - s_copy(temp, "POTENTIALLY RECOVERABLE ERROR,", (ftnlen)30, ( - ftnlen)30); - ltemp = 30; - } else { - s_copy(temp, "FATAL ERROR,", (ftnlen)12, (ftnlen)12); - ltemp = 12; - } - -/* THEN WHETHER THE PROGRAM WILL CONTINUE. */ - - if ((mkntrl == 2 && *level >= 1) || (mkntrl == 1 && *level == 2)) { - i__1 = ltemp; - s_copy(temp + i__1, " PROG ABORTED,", ltemp + 14 - i__1, (ftnlen) - 14); - ltemp += 14; - } else { - i__1 = ltemp; - s_copy(temp + i__1, " PROG CONTINUES,", ltemp + 16 - i__1, ( - ftnlen)16); - ltemp += 16; - } - -/* FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. */ - - if (lkntrl > 0) { - i__1 = ltemp; - s_copy(temp + i__1, " TRACEBACK REQUESTED", ltemp + 20 - i__1, ( - ftnlen)20); - ltemp += 20; - } else { - i__1 = ltemp; - s_copy(temp + i__1, " TRACEBACK NOT REQUESTED", ltemp + 24 - i__1, - (ftnlen)24); - ltemp += 24; - } - xerprn_(" ***", &c_n1, temp, &c__72, (ftnlen)4, ltemp); - } - -/* NOW SEND OUT THE MESSAGE. */ - - xerprn_(" * ", &c_n1, messg, &c__72, (ftnlen)4, messg_len); - -/* IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A */ -/* TRACEBACK. */ - - if (lkntrl > 0) { - ici__1.icierr = 0; - ici__1.icirnum = 1; - ici__1.icirlen = 72; - ici__1.iciunit = temp; - ici__1.icifmt = "('ERROR NUMBER = ', I8)"; - s_wsfi(&ici__1); - do_fio(&c__1, (char *)&(*nerr), (ftnlen)sizeof(integer)); - e_wsfi(); - for (i__ = 16; i__ <= 22; ++i__) { - if (*(unsigned char *)&temp[i__ - 1] != ' ') { - goto L20; - } -/* L10: */ - } - -L20: -/* Writing concatenation */ - i__3[0] = 15, a__1[0] = temp; - i__3[1] = 23 - (i__ - 1), a__1[1] = temp + (i__ - 1); - s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)87); - xerprn_(" * ", &c_n1, ch__1, &c__72, (ftnlen)4, 23 - (i__ - 1) + 15); - fdump_(); - } - -/* IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. */ - - if (lkntrl != 0) { - xerprn_(" * ", &c_n1, " ", &c__72, (ftnlen)4, (ftnlen)1); - xerprn_(" ***", &c_n1, "END OF MESSAGE", &c__72, (ftnlen)4, (ftnlen) - 14); - xerprn_(" ", &c__0, " ", &c__72, (ftnlen)4, (ftnlen)1); - } - -/* IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE */ -/* CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. */ - -L30: - if ((*level <= 0) || (*level == 1 && mkntrl <= 1)) { - return 0; - } - -/* THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A */ -/* FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR */ -/* SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. */ - - if (lkntrl > 0 && kount < max(1,maxmes)) { - if (*level == 1) { - xerprn_(" ***", &c_n1, "JOB ABORT DUE TO UNRECOVERED ERROR.", & - c__72, (ftnlen)4, (ftnlen)35); - } else { - xerprn_(" ***", &c_n1, "JOB ABORT DUE TO FATAL ERROR.", &c__72, ( - ftnlen)4, (ftnlen)29); - } - xersve_(" ", " ", " ", &c_n1, &c__0, &c__0, &kdummy, (ftnlen)1, ( - ftnlen)1, (ftnlen)1); - xerhlt_(" ", (ftnlen)1); - } else { - xerhlt_(messg, messg_len); - } - return 0; -} /* xermsg_ */ - diff --git a/ext/f2c_math/xerprn.c b/ext/f2c_math/xerprn.c deleted file mode 100644 index 433dcd84d..000000000 --- a/ext/f2c_math/xerprn.c +++ /dev/null @@ -1,289 +0,0 @@ -/* xerprn.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__4 = 4; - -/* DECK XERPRN */ -/* Subroutine */ int xerprn_(char *prefix, integer *npref, char *messg, - integer *nwrap, ftnlen prefix_len, ftnlen messg_len) -{ - /* System generated locals */ - integer i__1, i__2; - - /* Builtin functions */ - integer i_len(char *, ftnlen); - /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); - integer i_indx(char *, char *, ftnlen, ftnlen), s_cmp(char *, char *, - ftnlen, ftnlen); - - /* Local variables */ - integer i__, n, iu[5]; - extern /* Subroutine */ int printstring_(char *, ftnlen); - char cbuff[148]; - integer lpref, nextc, lwrap, nunit; - extern integer i1mach_(integer *); - integer lpiece, idelta, lenmsg; - extern /* Subroutine */ int xgetua_(integer *, integer *); - -/* ***BEGIN PROLOGUE XERPRN */ -/* ***SUBSIDIARY */ -/* ***PURPOSE Print error messages processed by XERMSG. */ -/* ***LIBRARY SLATEC (XERROR) */ -/* ***CATEGORY R3C */ -/* ***TYPE ALL (XERPRN-A) */ -/* ***KEYWORDS ERROR MESSAGES, PRINTING, XERROR */ -/* ***AUTHOR Fong, Kirby, (NMFECC at LLNL) */ -/* ***DESCRIPTION */ - -/* This routine sends one or more lines to each of the (up to five) */ -/* logical units to which error messages are to be sent. This routine */ -/* is called several times by XERMSG, sometimes with a single line to */ -/* print and sometimes with a (potentially very long) message that may */ -/* wrap around into multiple lines. */ - -/* PREFIX Input argument of type CHARACTER. This argument contains */ -/* characters to be put at the beginning of each line before */ -/* the body of the message. No more than 16 characters of */ -/* PREFIX will be used. */ - -/* NPREF Input argument of type INTEGER. This argument is the number */ -/* of characters to use from PREFIX. If it is negative, the */ -/* intrinsic function LEN is used to determine its length. If */ -/* it is zero, PREFIX is not used. If it exceeds 16 or if */ -/* LEN(PREFIX) exceeds 16, only the first 16 characters will be */ -/* used. If NPREF is positive and the length of PREFIX is less */ -/* than NPREF, a copy of PREFIX extended with blanks to length */ -/* NPREF will be used. */ - -/* MESSG Input argument of type CHARACTER. This is the text of a */ -/* message to be printed. If it is a long message, it will be */ -/* broken into pieces for printing on multiple lines. Each line */ -/* will start with the appropriate prefix and be followed by a */ -/* piece of the message. NWRAP is the number of characters per */ -/* piece; that is, after each NWRAP characters, we break and */ -/* start a new line. In addition the characters '$$' embedded */ -/* in MESSG are a sentinel for a new line. The counting of */ -/* characters up to NWRAP starts over for each new line. The */ -/* value of NWRAP typically used by XERMSG is 72 since many */ -/* older error messages in the SLATEC Library are laid out to */ -/* rely on wrap-around every 72 characters. */ - -/* NWRAP Input argument of type INTEGER. This gives the maximum size */ -/* piece into which to break MESSG for printing on multiple */ -/* lines. An embedded '$$' ends a line, and the count restarts */ -/* at the following character. If a line break does not occur */ -/* on a blank (it would split a word) that word is moved to the */ -/* next line. Values of NWRAP less than 16 will be treated as */ -/* 16. Values of NWRAP greater than 132 will be treated as 132. */ -/* The actual line length will be NPREF + NWRAP after NPREF has */ -/* been adjusted to fall between 0 and 16 and NWRAP has been */ -/* adjusted to fall between 16 and 132. */ - -/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ -/* Error-handling Package, SAND82-0800, Sandia */ -/* Laboratories, 1982. */ -/* ***ROUTINES CALLED I1MACH, XGETUA */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 880621 DATE WRITTEN */ -/* 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF */ -/* JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK */ -/* THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE */ -/* SLASH CHARACTER IN FORMAT STATEMENTS. */ -/* 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO */ -/* STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK */ -/* LINES TO BE PRINTED. */ -/* 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF */ -/* CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. */ -/* 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. */ -/* 891214 Prologue converted to Version 4.0 format. (WRB) */ -/* 900510 Added code to break messages between words. (RWC) */ -/* 920501 Reformatted the REFERENCES section. (WRB) */ -/* ***END PROLOGUE XERPRN */ -/* ***FIRST EXECUTABLE STATEMENT XERPRN */ - xgetua_(iu, &nunit); - -/* A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD */ -/* ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD */ -/* ERROR MESSAGE UNIT. */ - - n = i1mach_(&c__4); - i__1 = nunit; - for (i__ = 1; i__ <= i__1; ++i__) { - if (iu[i__ - 1] == 0) { - iu[i__ - 1] = n; - } -/* L10: */ - } - -/* LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE */ -/* BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING */ -/* THE REST OF THIS ROUTINE. */ - - if (*npref < 0) { - lpref = i_len(prefix, prefix_len); - } else { - lpref = *npref; - } - lpref = min(16,lpref); - if (lpref != 0) { - s_copy(cbuff, prefix, lpref, prefix_len); - } - -/* LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE */ -/* TIME FROM MESSG TO PRINT ON ONE LINE. */ - -/* Computing MAX */ - i__1 = 16, i__2 = min(132,*nwrap); - lwrap = max(i__1,i__2); - -/* SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. */ - - lenmsg = i_len(messg, messg_len); - n = lenmsg; - i__1 = n; - for (i__ = 1; i__ <= i__1; ++i__) { - if (*(unsigned char *)&messg[lenmsg - 1] != ' ') { - goto L30; - } - --lenmsg; -/* L20: */ - } -L30: - -/* IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. */ - - if (lenmsg == 0) { - i__1 = lpref; - s_copy(cbuff + i__1, " ", lpref + 1 - i__1, (ftnlen)1); - printstring_(cbuff, (ftnlen)148); -/* DO 40 I=1,NUNIT */ -/* WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) */ -/* 40 CONTINUE */ - return 0; - } - -/* SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING */ -/* STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. */ -/* WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. */ -/* WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. */ - -/* WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE */ -/* INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE */ -/* OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH */ -/* OF THE SECOND ARGUMENT. */ - -/* THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE */ -/* FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER */ -/* OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT */ -/* POSITION NEXTC. */ - -/* LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE */ -/* REMAINDER OF THE CHARACTER STRING. LPIECE */ -/* SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, */ -/* WHICHEVER IS LESS. */ - -/* LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: */ -/* NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE */ -/* PRINT NOTHING TO AVOID PRODUCING UNNECESSARY */ -/* BLANK LINES. THIS TAKES CARE OF THE SITUATION */ -/* WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF */ -/* EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE */ -/* SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC */ -/* SHOULD BE INCREMENTED BY 2. */ - -/* LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. */ - -/* ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 */ -/* RESET LPIECE = LPIECE-1. NOTE THAT THIS */ -/* PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. */ -/* LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY */ -/* AT THE END OF A LINE. */ - - nextc = 1; -L50: - lpiece = i_indx(messg + (nextc - 1), "$$", lenmsg - (nextc - 1), (ftnlen) - 2); - if (lpiece == 0) { - -/* THERE WAS NO NEW LINE SENTINEL FOUND. */ - - idelta = 0; -/* Computing MIN */ - i__1 = lwrap, i__2 = lenmsg + 1 - nextc; - lpiece = min(i__1,i__2); - if (lpiece < lenmsg + 1 - nextc) { - for (i__ = lpiece + 1; i__ >= 2; --i__) { - i__1 = nextc + i__ - 2; - if (s_cmp(messg + i__1, " ", nextc + i__ - 1 - i__1, (ftnlen) - 1) == 0) { - lpiece = i__ - 1; - idelta = 1; - goto L54; - } -/* L52: */ - } - } -L54: - i__1 = lpref; - s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1, - nextc + lpiece - 1 - (nextc - 1)); - nextc = nextc + lpiece + idelta; - } else if (lpiece == 1) { - -/* WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). */ -/* DON'T PRINT A BLANK LINE. */ - - nextc += 2; - goto L50; - } else if (lpiece > lwrap + 1) { - -/* LPIECE SHOULD BE SET DOWN TO LWRAP. */ - - idelta = 0; - lpiece = lwrap; - for (i__ = lpiece + 1; i__ >= 2; --i__) { - i__1 = nextc + i__ - 2; - if (s_cmp(messg + i__1, " ", nextc + i__ - 1 - i__1, (ftnlen)1) == - 0) { - lpiece = i__ - 1; - idelta = 1; - goto L58; - } -/* L56: */ - } -L58: - i__1 = lpref; - s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1, - nextc + lpiece - 1 - (nextc - 1)); - nextc = nextc + lpiece + idelta; - } else { - -/* IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. */ -/* WE SHOULD DECREMENT LPIECE BY ONE. */ - - --lpiece; - i__1 = lpref; - s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1, - nextc + lpiece - 1 - (nextc - 1)); - nextc = nextc + lpiece + 2; - } - -/* PRINT */ - - printstring_(cbuff, (ftnlen)148); -/* DO 60 I=1,NUNIT */ -/* WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) */ -/* 60 CONTINUE */ - - if (nextc <= lenmsg) { - goto L50; - } - return 0; -} /* xerprn_ */ - diff --git a/ext/f2c_math/xersve.c b/ext/f2c_math/xersve.c deleted file mode 100644 index 4967c5a3e..000000000 --- a/ext/f2c_math/xersve.c +++ /dev/null @@ -1,227 +0,0 @@ -/* xersve.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__4 = 4; -static integer c__1 = 1; - -/* DECK XERSVE */ -/* Subroutine */ int xersve_(char *librar, char *subrou, char *messg, integer - *kflag, integer *nerr, integer *level, integer *icount, ftnlen - librar_len, ftnlen subrou_len, ftnlen messg_len) -{ - /* Initialized data */ - - static integer kountx = 0; - static integer nmsg = 0; - - /* Format strings */ - static char fmt_9000[] = "(\0020 ERROR MESSAGE SUMMARY\002/\002" - " LIBRARY SUBROUTINE MESSAGE START NERR\002,\002 " - " LEVEL COUNT\002)"; - static char fmt_9010[] = "(1x,a,3x,a,3x,a,3i10)"; - static char fmt_9020[] = "(\0020OTHER ERRORS NOT INDIVIDUALLY TABULATED " - "= \002,i10)"; - static char fmt_9030[] = "(1x)"; - - /* System generated locals */ - integer i__1, i__2; - - /* Builtin functions */ - integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen); - /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen); - integer s_cmp(char *, char *, ftnlen, ftnlen); - - /* Local variables */ - integer i__; - char lib[8], mes[20], sub[8]; - integer lun[5], iunit, kunit, nunit; - static integer kount[10]; - extern integer i1mach_(integer *); - static char libtab[8*10], mestab[20*10]; - static integer nertab[10], levtab[10]; - static char subtab[8*10]; - extern /* Subroutine */ int xgetua_(integer *, integer *); - - /* Fortran I/O blocks */ - static cilist io___7 = { 0, 0, 0, fmt_9000, 0 }; - static cilist io___9 = { 0, 0, 0, fmt_9010, 0 }; - static cilist io___16 = { 0, 0, 0, fmt_9020, 0 }; - static cilist io___17 = { 0, 0, 0, fmt_9030, 0 }; - - -/* ***BEGIN PROLOGUE XERSVE */ -/* ***SUBSIDIARY */ -/* ***PURPOSE Record that an error has occurred. */ -/* ***LIBRARY SLATEC (XERROR) */ -/* ***CATEGORY R3 */ -/* ***TYPE ALL (XERSVE-A) */ -/* ***KEYWORDS ERROR, XERROR */ -/* ***AUTHOR Jones, R. E., (SNLA) */ -/* ***DESCRIPTION */ - -/* *Usage: */ - -/* INTEGER KFLAG, NERR, LEVEL, ICOUNT */ -/* CHARACTER * (len) LIBRAR, SUBROU, MESSG */ - -/* CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) */ - -/* *Arguments: */ - -/* LIBRAR :IN is the library that the message is from. */ -/* SUBROU :IN is the subroutine that the message is from. */ -/* MESSG :IN is the message to be saved. */ -/* KFLAG :IN indicates the action to be performed. */ -/* when KFLAG > 0, the message in MESSG is saved. */ -/* when KFLAG=0 the tables will be dumped and */ -/* cleared. */ -/* when KFLAG < 0, the tables will be dumped and */ -/* not cleared. */ -/* NERR :IN is the error number. */ -/* LEVEL :IN is the error severity. */ -/* ICOUNT :OUT the number of times this message has been seen, */ -/* or zero if the table has overflowed and does not */ -/* contain this message specifically. When KFLAG=0, */ -/* ICOUNT will not be altered. */ - -/* *Description: */ - -/* Record that this error occurred and possibly dump and clear the */ -/* tables. */ - -/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ -/* Error-handling Package, SAND82-0800, Sandia */ -/* Laboratories, 1982. */ -/* ***ROUTINES CALLED I1MACH, XGETUA */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 800319 DATE WRITTEN */ -/* 861211 REVISION DATE from Version 3.2 */ -/* 891214 Prologue converted to Version 4.0 format. (BAB) */ -/* 900413 Routine modified to remove reference to KFLAG. (WRB) */ -/* 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling */ -/* sequence, use IF-THEN-ELSE, make number of saved entries */ -/* easily changeable, changed routine name from XERSAV to */ -/* XERSVE. (RWC) */ -/* 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) */ -/* 920501 Reformatted the REFERENCES section. (WRB) */ -/* ***END PROLOGUE XERSVE */ -/* ***FIRST EXECUTABLE STATEMENT XERSVE */ - - if (*kflag <= 0) { - -/* Dump the table. */ - - if (nmsg == 0) { - return 0; - } - -/* Print to each unit. */ - - xgetua_(lun, &nunit); - i__1 = nunit; - for (kunit = 1; kunit <= i__1; ++kunit) { - iunit = lun[kunit - 1]; - if (iunit == 0) { - iunit = i1mach_(&c__4); - } - -/* Print the table header. */ - - io___7.ciunit = iunit; - s_wsfe(&io___7); - e_wsfe(); - -/* Print body of table. */ - - i__2 = nmsg; - for (i__ = 1; i__ <= i__2; ++i__) { - io___9.ciunit = iunit; - s_wsfe(&io___9); - do_fio(&c__1, libtab + ((i__ - 1) << 3), (ftnlen)8); - do_fio(&c__1, subtab + ((i__ - 1) << 3), (ftnlen)8); - do_fio(&c__1, mestab + (i__ - 1) * 20, (ftnlen)20); - do_fio(&c__1, (char *)&nertab[i__ - 1], (ftnlen)sizeof( - integer)); - do_fio(&c__1, (char *)&levtab[i__ - 1], (ftnlen)sizeof( - integer)); - do_fio(&c__1, (char *)&kount[i__ - 1], (ftnlen)sizeof(integer) - ); - e_wsfe(); -/* L10: */ - } - -/* Print number of other errors. */ - - if (kountx != 0) { - io___16.ciunit = iunit; - s_wsfe(&io___16); - do_fio(&c__1, (char *)&kountx, (ftnlen)sizeof(integer)); - e_wsfe(); - } - io___17.ciunit = iunit; - s_wsfe(&io___17); - e_wsfe(); -/* L20: */ - } - -/* Clear the error tables. */ - - if (*kflag == 0) { - nmsg = 0; - kountx = 0; - } - } else { - -/* PROCESS A MESSAGE... */ -/* SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, */ -/* OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. */ - - s_copy(lib, librar, (ftnlen)8, librar_len); - s_copy(sub, subrou, (ftnlen)8, subrou_len); - s_copy(mes, messg, (ftnlen)20, messg_len); - i__1 = nmsg; - for (i__ = 1; i__ <= i__1; ++i__) { - if (s_cmp(lib, libtab + ((i__ - 1) << 3), (ftnlen)8, (ftnlen)8) == - 0 && s_cmp(sub, subtab + ((i__ - 1) << 3), (ftnlen)8, ( - ftnlen)8) == 0 && s_cmp(mes, mestab + (i__ - 1) * 20, ( - ftnlen)20, (ftnlen)20) == 0 && *nerr == nertab[i__ - 1] && - *level == levtab[i__ - 1]) { - ++kount[i__ - 1]; - *icount = kount[i__ - 1]; - return 0; - } -/* L30: */ - } - - if (nmsg < 10) { - -/* Empty slot found for new message. */ - - ++nmsg; - s_copy(libtab + ((i__ - 1) << 3), lib, (ftnlen)8, (ftnlen)8); - s_copy(subtab + ((i__ - 1) << 3), sub, (ftnlen)8, (ftnlen)8); - s_copy(mestab + (i__ - 1) * 20, mes, (ftnlen)20, (ftnlen)20); - nertab[i__ - 1] = *nerr; - levtab[i__ - 1] = *level; - kount[i__ - 1] = 1; - *icount = 1; - } else { - -/* Table is full. */ - - ++kountx; - *icount = 0; - } - } - return 0; - -/* Formats. */ - -} /* xersve_ */ - diff --git a/ext/f2c_math/xgetua.c b/ext/f2c_math/xgetua.c deleted file mode 100644 index a39f2c5d8..000000000 --- a/ext/f2c_math/xgetua.c +++ /dev/null @@ -1,80 +0,0 @@ -/* xgetua.f -- translated by f2c (version 20030320). - You must link the resulting object file with the libraries: - -lf2c -lm (in that order) -*/ - -#include "f2c.h" - -/* Table of constant values */ - -static integer c__5 = 5; -static integer c__0 = 0; -static logical c_false = FALSE_; - -/* DECK XGETUA */ -/* Subroutine */ int xgetua_(integer *iunita, integer *n) -{ - /* System generated locals */ - integer i__1; - - /* Local variables */ - integer i__, index; - extern integer j4save_(integer *, integer *, logical *); - -/* ***BEGIN PROLOGUE XGETUA */ -/* ***PURPOSE Return unit number(s) to which error messages are being */ -/* sent. */ -/* ***LIBRARY SLATEC (XERROR) */ -/* ***CATEGORY R3C */ -/* ***TYPE ALL (XGETUA-A) */ -/* ***KEYWORDS ERROR, XERROR */ -/* ***AUTHOR Jones, R. E., (SNLA) */ -/* ***DESCRIPTION */ - -/* Abstract */ -/* XGETUA may be called to determine the unit number or numbers */ -/* to which error messages are being sent. */ -/* These unit numbers may have been set by a call to XSETUN, */ -/* or a call to XSETUA, or may be a default value. */ - -/* Description of Parameters */ -/* --Output-- */ -/* IUNIT - an array of one to five unit numbers, depending */ -/* on the value of N. A value of zero refers to the */ -/* default unit, as defined by the I1MACH machine */ -/* constant routine. Only IUNIT(1),...,IUNIT(N) are */ -/* defined by XGETUA. The values of IUNIT(N+1),..., */ -/* IUNIT(5) are not defined (for N .LT. 5) or altered */ -/* in any way by XGETUA. */ -/* N - the number of units to which copies of the */ -/* error messages are being sent. N will be in the */ -/* range from 1 to 5. */ - -/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */ -/* Error-handling Package, SAND82-0800, Sandia */ -/* Laboratories, 1982. */ -/* ***ROUTINES CALLED J4SAVE */ -/* ***REVISION HISTORY (YYMMDD) */ -/* 790801 DATE WRITTEN */ -/* 861211 REVISION DATE from Version 3.2 */ -/* 891214 Prologue converted to Version 4.0 format. (BAB) */ -/* 920501 Reformatted the REFERENCES section. (WRB) */ -/* ***END PROLOGUE XGETUA */ -/* ***FIRST EXECUTABLE STATEMENT XGETUA */ - /* Parameter adjustments */ - --iunita; - - /* Function Body */ - *n = j4save_(&c__5, &c__0, &c_false); - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { - index = i__ + 4; - if (i__ == 1) { - index = 3; - } - iunita[i__] = j4save_(&index, &c__0, &c_false); -/* L30: */ - } - return 0; -} /* xgetua_ */ - diff --git a/ext/lapack/dbdsqr.f b/ext/lapack/dbdsqr.f deleted file mode 100644 index e89063a7f..000000000 --- a/ext/lapack/dbdsqr.f +++ /dev/null @@ -1,807 +0,0 @@ - SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, - $ LDU, C, LDC, WORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ), - $ VT( LDVT, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DBDSQR computes the singular value decomposition (SVD) of a real -* N-by-N (upper or lower) bidiagonal matrix B: B = Q * S * P' (P' -* denotes the transpose of P), where S is a diagonal matrix with -* non-negative diagonal elements (the singular values of B), and Q -* and P are orthogonal matrices. -* -* The routine computes S, and optionally computes U * Q, P' * VT, -* or Q' * C, for given real input matrices U, VT, and C. -* -* See "Computing Small Singular Values of Bidiagonal Matrices With -* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, -* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, -* no. 5, pp. 873-912, Sept 1990) and -* "Accurate singular values and differential qd algorithms," by -* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics -* Department, University of California at Berkeley, July 1992 -* for a detailed description of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': B is upper bidiagonal; -* = 'L': B is lower bidiagonal. -* -* N (input) INTEGER -* The order of the matrix B. N >= 0. -* -* NCVT (input) INTEGER -* The number of columns of the matrix VT. NCVT >= 0. -* -* NRU (input) INTEGER -* The number of rows of the matrix U. NRU >= 0. -* -* NCC (input) INTEGER -* The number of columns of the matrix C. NCC >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the n diagonal elements of the bidiagonal matrix B. -* On exit, if INFO=0, the singular values of B in decreasing -* order. -* -* E (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the elements of E contain the -* offdiagonal elements of the bidiagonal matrix whose SVD -* is desired. On normal exit (INFO = 0), E is destroyed. -* If the algorithm does not converge (INFO > 0), D and E -* will contain the diagonal and superdiagonal elements of a -* bidiagonal matrix orthogonally equivalent to the one given -* as input. E(N) is used for workspace. -* -* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT) -* On entry, an N-by-NCVT matrix VT. -* On exit, VT is overwritten by P' * VT. -* VT is not referenced if NCVT = 0. -* -* LDVT (input) INTEGER -* The leading dimension of the array VT. -* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. -* -* U (input/output) DOUBLE PRECISION array, dimension (LDU, N) -* On entry, an NRU-by-N matrix U. -* On exit, U is overwritten by U * Q. -* U is not referenced if NRU = 0. -* -* LDU (input) INTEGER -* The leading dimension of the array U. LDU >= max(1,NRU). -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC) -* On entry, an N-by-NCC matrix C. -* On exit, C is overwritten by Q' * C. -* C is not referenced if NCC = 0. -* -* LDC (input) INTEGER -* The leading dimension of the array C. -* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0. -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* 2*N if only singular values wanted (NCVT = NRU = NCC = 0) -* max( 1, 4*N-4 ) otherwise -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: If INFO = -i, the i-th argument had an illegal value -* > 0: the algorithm did not converge; D and E contain the -* elements of a bidiagonal matrix which is orthogonally -* similar to the input matrix B; if INFO = i, i -* elements of E have not converged to zero. -* -* Internal Parameters -* =================== -* -* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8))) -* TOLMUL controls the convergence criterion of the QR loop. -* If it is positive, TOLMUL*EPS is the desired relative -* precision in the computed singular values. -* If it is negative, abs(TOLMUL*EPS*sigma_max) is the -* desired absolute accuracy in the computed singular -* values (corresponds to relative accuracy -* abs(TOLMUL*EPS) in the largest singular value. -* abs(TOLMUL) should be between 1 and 1/EPS, and preferably -* between 10 (for fast convergence) and .1/EPS -* (for there to be some accuracy in the results). -* Default is to lose at either one eighth or 2 of the -* available decimal digits in each computed singular value -* (whichever is smaller). -* -* MAXITR INTEGER, default = 6 -* MAXITR controls the maximum number of passes of the -* algorithm through its inner loop. The algorithms stops -* (and so fails to converge) if the number of passes -* through the inner loop exceeds MAXITR*N**2. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION NEGONE - PARAMETER ( NEGONE = -1.0D0 ) - DOUBLE PRECISION HNDRTH - PARAMETER ( HNDRTH = 0.01D0 ) - DOUBLE PRECISION TEN - PARAMETER ( TEN = 10.0D0 ) - DOUBLE PRECISION HNDRD - PARAMETER ( HNDRD = 100.0D0 ) - DOUBLE PRECISION MEIGTH - PARAMETER ( MEIGTH = -0.125D0 ) - INTEGER MAXITR - PARAMETER ( MAXITR = 6 ) -* .. -* .. Local Scalars .. - LOGICAL ROTATE - INTEGER I, IDIR, IROT, ISUB, ITER, IUPLO, J, LL, LLL, - $ M, MAXIT, NM1, NM12, NM13, OLDLL, OLDM - DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU, - $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL, - $ SINR, SLL, SMAX, SMIN, SMINL, SMINLO, SMINOA, - $ SN, THRESH, TOL, TOLMUL, UNFL -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLARTG, DLAS2, DLASQ1, DLASR, DLASV2, DROT, - $ DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IUPLO = 0 - IF( LSAME( UPLO, 'U' ) ) - $ IUPLO = 1 - IF( LSAME( UPLO, 'L' ) ) - $ IUPLO = 2 - IF( IUPLO.EQ.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NCVT.LT.0 ) THEN - INFO = -3 - ELSE IF( NRU.LT.0 ) THEN - INFO = -4 - ELSE IF( NCC.LT.0 ) THEN - INFO = -5 - ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR. - $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN - INFO = -9 - ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN - INFO = -11 - ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR. - $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN - INFO = -13 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DBDSQR', -INFO ) - RETURN - END IF - IF( N.EQ.0 ) - $ RETURN - IF( N.EQ.1 ) - $ GO TO 150 -* -* ROTATE is true if any singular vectors desired, false otherwise -* - ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 ) -* -* If no singular vectors desired, use qd algorithm -* - IF( .NOT.ROTATE ) THEN - CALL DLASQ1( N, D, E, WORK, INFO ) - RETURN - END IF -* - NM1 = N - 1 - NM12 = NM1 + NM1 - NM13 = NM12 + NM1 -* -* Get machine constants -* - EPS = DLAMCH( 'Epsilon' ) - UNFL = DLAMCH( 'Safe minimum' ) -* -* If matrix lower bidiagonal, rotate to be upper bidiagonal -* by applying Givens rotations on the left -* - IF( IUPLO.EQ.2 ) THEN - DO 10 I = 1, N - 1 - CALL DLARTG( D( I ), E( I ), CS, SN, R ) - D( I ) = R - E( I ) = SN*D( I+1 ) - D( I+1 ) = CS*D( I+1 ) - WORK( I ) = CS - WORK( NM1+I ) = SN - 10 CONTINUE -* -* Update singular vectors if desired -* - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U, - $ LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C, - $ LDC ) - END IF -* -* Compute singular values to relative accuracy TOL -* (By setting TOL to be negative, algorithm will compute -* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) -* - TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) ) - TOL = TOLMUL*EPS -* -* Compute approximate maximum, minimum singular values -* - SMAX = ABS( D( N ) ) - DO 20 I = 1, N - 1 - SMAX = MAX( SMAX, ABS( D( I ) ), ABS( E( I ) ) ) - 20 CONTINUE - SMINL = ZERO - IF( TOL.GE.ZERO ) THEN -* -* Relative accuracy desired -* - SMINOA = ABS( D( 1 ) ) - IF( SMINOA.EQ.ZERO ) - $ GO TO 40 - MU = SMINOA - DO 30 I = 2, N - MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) ) - SMINOA = MIN( SMINOA, MU ) - IF( SMINOA.EQ.ZERO ) - $ GO TO 40 - 30 CONTINUE - 40 CONTINUE - SMINOA = SMINOA / SQRT( DBLE( N ) ) - THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL ) - ELSE -* -* Absolute accuracy desired -* - THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL ) - END IF -* -* Prepare for main iteration loop for the singular values -* (MAXIT is the maximum number of passes through the inner -* loop permitted before nonconvergence signalled.) -* - MAXIT = MAXITR*N*N - ITER = 0 - OLDLL = -1 - OLDM = -1 -* -* M points to last element of unconverged part of matrix -* - M = N -* -* Begin main iteration loop -* - 50 CONTINUE -* -* Check for convergence or exceeding iteration count -* - IF( M.LE.1 ) - $ GO TO 150 - IF( ITER.GT.MAXIT ) - $ GO TO 190 -* -* Find diagonal block of matrix to work on -* - IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH ) - $ D( M ) = ZERO - SMAX = ABS( D( M ) ) - SMIN = SMAX - DO 60 LLL = 1, M - LL = M - LLL - IF( LL.EQ.0 ) - $ GO TO 80 - ABSS = ABS( D( LL ) ) - ABSE = ABS( E( LL ) ) - IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH ) - $ D( LL ) = ZERO - IF( ABSE.LE.THRESH ) - $ GO TO 70 - SMIN = MIN( SMIN, ABSS ) - SMAX = MAX( SMAX, ABSS, ABSE ) - 60 CONTINUE - 70 CONTINUE - E( LL ) = ZERO -* -* Matrix splits since E(LL) = 0 -* - IF( LL.EQ.M-1 ) THEN -* -* Convergence of bottom singular value, return to top of loop -* - M = M - 1 - GO TO 50 - END IF - 80 CONTINUE - LL = LL + 1 -* -* E(LL) through E(M-1) are nonzero, E(LL-1) is zero -* - IF( LL.EQ.M-1 ) THEN -* -* 2 by 2 block, handle separately -* - CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR, - $ COSR, SINL, COSL ) - D( M-1 ) = SIGMX - E( M-1 ) = ZERO - D( M ) = SIGMN -* -* Compute singular vectors, if desired -* - IF( NCVT.GT.0 ) - $ CALL DROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR, - $ SINR ) - IF( NRU.GT.0 ) - $ CALL DROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL ) - IF( NCC.GT.0 ) - $ CALL DROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL, - $ SINL ) - M = M - 2 - GO TO 50 - END IF -* -* If working on new submatrix, choose shift direction -* (from larger end diagonal element towards smaller) -* - IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN - IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN -* -* Chase bulge from top (big end) to bottom (small end) -* - IDIR = 1 - ELSE -* -* Chase bulge from bottom (big end) to top (small end) -* - IDIR = 2 - END IF - END IF -* -* Apply convergence tests -* - IF( IDIR.EQ.1 ) THEN -* -* Run convergence test in forward direction -* First apply standard test to bottom of matrix -* - IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR. - $ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN - E( M-1 ) = ZERO - GO TO 50 - END IF -* - IF( TOL.GE.ZERO ) THEN -* -* If relative accuracy desired, -* apply convergence criterion forward -* - MU = ABS( D( LL ) ) - SMINL = MU - DO 90 LLL = LL, M - 1 - IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN - E( LLL ) = ZERO - GO TO 50 - END IF - SMINLO = SMINL - MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) - SMINL = MIN( SMINL, MU ) - 90 CONTINUE - END IF -* - ELSE -* -* Run convergence test in backward direction -* First apply standard test to top of matrix -* - IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR. - $ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN - E( LL ) = ZERO - GO TO 50 - END IF -* - IF( TOL.GE.ZERO ) THEN -* -* If relative accuracy desired, -* apply convergence criterion backward -* - MU = ABS( D( M ) ) - SMINL = MU - DO 100 LLL = M - 1, LL, -1 - IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN - E( LLL ) = ZERO - GO TO 50 - END IF - SMINLO = SMINL - MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) ) - SMINL = MIN( SMINL, MU ) - 100 CONTINUE - END IF - END IF - OLDLL = LL - OLDM = M -* -* Compute shift. First, test if shifting would ruin relative -* accuracy, and if so set the shift to zero. -* - IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE. - $ MAX( EPS, HNDRTH*TOL ) ) THEN -* -* Use a zero shift to avoid loss of relative accuracy -* - SHIFT = ZERO - ELSE -* -* Compute the shift from 2-by-2 block at end of matrix -* - IF( IDIR.EQ.1 ) THEN - SLL = ABS( D( LL ) ) - CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R ) - ELSE - SLL = ABS( D( M ) ) - CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R ) - END IF -* -* Test if shift negligible, and if so set to zero -* - IF( SLL.GT.ZERO ) THEN - IF( ( SHIFT / SLL )**2.LT.EPS ) - $ SHIFT = ZERO - END IF - END IF -* -* Increment iteration count -* - ITER = ITER + M - LL -* -* If SHIFT = 0, do simplified QR iteration -* - IF( SHIFT.EQ.ZERO ) THEN - IF( IDIR.EQ.1 ) THEN -* -* Chase bulge from top to bottom -* Save cosines and sines for later singular vector updates -* - CS = ONE - OLDCS = ONE - CALL DLARTG( D( LL )*CS, E( LL ), CS, SN, R ) - CALL DLARTG( OLDCS*R, D( LL+1 )*SN, OLDCS, OLDSN, D( LL ) ) - WORK( 1 ) = CS - WORK( 1+NM1 ) = SN - WORK( 1+NM12 ) = OLDCS - WORK( 1+NM13 ) = OLDSN - IROT = 1 - DO 110 I = LL + 1, M - 1 - CALL DLARTG( D( I )*CS, E( I ), CS, SN, R ) - E( I-1 ) = OLDSN*R - CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) ) - IROT = IROT + 1 - WORK( IROT ) = CS - WORK( IROT+NM1 ) = SN - WORK( IROT+NM12 ) = OLDCS - WORK( IROT+NM13 ) = OLDSN - 110 CONTINUE - H = D( M )*CS - D( M ) = H*OLDCS - E( M-1 ) = H*OLDSN -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), - $ WORK( N ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), - $ WORK( NM13+1 ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), - $ WORK( NM13+1 ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( M-1 ) ).LE.THRESH ) - $ E( M-1 ) = ZERO -* - ELSE -* -* Chase bulge from bottom to top -* Save cosines and sines for later singular vector updates -* - CS = ONE - OLDCS = ONE - CALL DLARTG( D( M )*CS, E( M-1 ), CS, SN, R ) - CALL DLARTG( OLDCS*R, D( M-1 )*SN, OLDCS, OLDSN, D( M ) ) - WORK( M-LL ) = CS - WORK( M-LL+NM1 ) = -SN - WORK( M-LL+NM12 ) = OLDCS - WORK( M-LL+NM13 ) = -OLDSN - IROT = M - LL - DO 120 I = M - 1, LL + 1, -1 - CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R ) - E( I ) = OLDSN*R - CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) ) - IROT = IROT - 1 - WORK( IROT ) = CS - WORK( IROT+NM1 ) = -SN - WORK( IROT+NM12 ) = OLDCS - WORK( IROT+NM13 ) = -OLDSN - 120 CONTINUE - H = D( LL )*CS - D( LL ) = H*OLDCS - E( LL ) = H*OLDSN -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), - $ WORK( NM13+1 ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), - $ WORK( N ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), - $ WORK( N ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( LL ) ).LE.THRESH ) - $ E( LL ) = ZERO - END IF - ELSE -* -* Use nonzero shift -* - IF( IDIR.EQ.1 ) THEN -* -* Chase bulge from top to bottom -* Save cosines and sines for later singular vector updates -* - F = ( ABS( D( LL ) )-SHIFT )* - $ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) ) - G = E( LL ) - CALL DLARTG( F, G, COSR, SINR, R ) - F = COSR*D( LL ) + SINR*E( LL ) - E( LL ) = COSR*E( LL ) - SINR*D( LL ) - G = SINR*D( LL+1 ) - D( LL+1 ) = COSR*D( LL+1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( LL ) = R - F = COSL*E( LL ) + SINL*D( LL+1 ) - D( LL+1 ) = COSL*D( LL+1 ) - SINL*E( LL ) - G = SINL*E( LL+1 ) - E( LL+1 ) = COSL*E( LL+1 ) - WORK( 1 ) = COSR - WORK( 1+NM1 ) = SINR - WORK( 1+NM12 ) = COSL - WORK( 1+NM13 ) = SINL - IROT = 1 - DO 130 I = LL + 1, M - 2 - CALL DLARTG( F, G, COSR, SINR, R ) - E( I-1 ) = R - F = COSR*D( I ) + SINR*E( I ) - E( I ) = COSR*E( I ) - SINR*D( I ) - G = SINR*D( I+1 ) - D( I+1 ) = COSR*D( I+1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( I ) = R - F = COSL*E( I ) + SINL*D( I+1 ) - D( I+1 ) = COSL*D( I+1 ) - SINL*E( I ) - G = SINL*E( I+1 ) - E( I+1 ) = COSL*E( I+1 ) - IROT = IROT + 1 - WORK( IROT ) = COSR - WORK( IROT+NM1 ) = SINR - WORK( IROT+NM12 ) = COSL - WORK( IROT+NM13 ) = SINL - 130 CONTINUE - CALL DLARTG( F, G, COSR, SINR, R ) - E( M-2 ) = R - F = COSR*D( M-1 ) + SINR*E( M-1 ) - E( M-1 ) = COSR*E( M-1 ) - SINR*D( M-1 ) - G = SINR*D( M ) - D( M ) = COSR*D( M ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( M-1 ) = R - F = COSL*E( M-1 ) + SINL*D( M ) - D( M ) = COSL*D( M ) - SINL*E( M-1 ) - IROT = IROT + 1 - WORK( IROT ) = COSR - WORK( IROT+NM1 ) = SINR - WORK( IROT+NM12 ) = COSL - WORK( IROT+NM13 ) = SINL - E( M-1 ) = F -* -* Update singular vectors -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ), - $ WORK( N ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ), - $ WORK( NM13+1 ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ), - $ WORK( NM13+1 ), C( LL, 1 ), LDC ) -* -* Test convergence -* - IF( ABS( E( M-1 ) ).LE.THRESH ) - $ E( M-1 ) = ZERO -* - ELSE -* -* Chase bulge from bottom to top -* Save cosines and sines for later singular vector updates -* - F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT / - $ D( M ) ) - G = E( M-1 ) - CALL DLARTG( F, G, COSR, SINR, R ) - F = COSR*D( M ) + SINR*E( M-1 ) - E( M-1 ) = COSR*E( M-1 ) - SINR*D( M ) - G = SINR*D( M-1 ) - D( M-1 ) = COSR*D( M-1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( M ) = R - F = COSL*E( M-1 ) + SINL*D( M-1 ) - D( M-1 ) = COSL*D( M-1 ) - SINL*E( M-1 ) - G = SINL*E( M-2 ) - E( M-2 ) = COSL*E( M-2 ) - WORK( M-LL ) = COSR - WORK( M-LL+NM1 ) = -SINR - WORK( M-LL+NM12 ) = COSL - WORK( M-LL+NM13 ) = -SINL - IROT = M - LL - DO 140 I = M - 1, LL + 2, -1 - CALL DLARTG( F, G, COSR, SINR, R ) - E( I ) = R - F = COSR*D( I ) + SINR*E( I-1 ) - E( I-1 ) = COSR*E( I-1 ) - SINR*D( I ) - G = SINR*D( I-1 ) - D( I-1 ) = COSR*D( I-1 ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( I ) = R - F = COSL*E( I-1 ) + SINL*D( I-1 ) - D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 ) - G = SINL*E( I-2 ) - E( I-2 ) = COSL*E( I-2 ) - IROT = IROT - 1 - WORK( IROT ) = COSR - WORK( IROT+NM1 ) = -SINR - WORK( IROT+NM12 ) = COSL - WORK( IROT+NM13 ) = -SINL - 140 CONTINUE - CALL DLARTG( F, G, COSR, SINR, R ) - E( LL+1 ) = R - F = COSR*D( LL+1 ) + SINR*E( LL ) - E( LL ) = COSR*E( LL ) - SINR*D( LL+1 ) - G = SINR*D( LL ) - D( LL ) = COSR*D( LL ) - CALL DLARTG( F, G, COSL, SINL, R ) - D( LL+1 ) = R - F = COSL*E( LL ) + SINL*D( LL ) - D( LL ) = COSL*D( LL ) - SINL*E( LL ) - IROT = IROT - 1 - WORK( IROT ) = COSR - WORK( IROT+NM1 ) = -SINR - WORK( IROT+NM12 ) = COSL - WORK( IROT+NM13 ) = -SINL - E( LL ) = F -* -* Test convergence -* - IF( ABS( E( LL ) ).LE.THRESH ) - $ E( LL ) = ZERO -* -* Update singular vectors if desired -* - IF( NCVT.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ), - $ WORK( NM13+1 ), VT( LL, 1 ), LDVT ) - IF( NRU.GT.0 ) - $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ), - $ WORK( N ), U( 1, LL ), LDU ) - IF( NCC.GT.0 ) - $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ), - $ WORK( N ), C( LL, 1 ), LDC ) - END IF - END IF -* -* QR iteration finished, go back and check convergence -* - GO TO 50 -* -* All singular values converged, so make them positive -* - 150 CONTINUE - DO 160 I = 1, N - IF( D( I ).LT.ZERO ) THEN - D( I ) = -D( I ) -* -* Change sign of singular vectors, if desired -* - IF( NCVT.GT.0 ) - $ CALL DSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT ) - END IF - 160 CONTINUE -* -* Sort the singular values into decreasing order (insertion sort on -* singular values, but only one transposition per singular vector) -* - DO 180 I = 1, N - 1 -* -* Scan for smallest D(I) -* - ISUB = 1 - SMIN = D( 1 ) - DO 170 J = 2, N + 1 - I - IF( D( J ).LE.SMIN ) THEN - ISUB = J - SMIN = D( J ) - END IF - 170 CONTINUE - IF( ISUB.NE.N+1-I ) THEN -* -* Swap singular values and vectors -* - D( ISUB ) = D( N+1-I ) - D( N+1-I ) = SMIN - IF( NCVT.GT.0 ) - $ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ), - $ LDVT ) - IF( NRU.GT.0 ) - $ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 ) - IF( NCC.GT.0 ) - $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC ) - END IF - 180 CONTINUE - GO TO 210 -* -* Maximum number of iterations exceeded, failure to converge -* - 190 CONTINUE - INFO = 0 - DO 200 I = 1, N - 1 - IF( E( I ).NE.ZERO ) - $ INFO = INFO + 1 - 200 CONTINUE - 210 CONTINUE - RETURN -* -* End of DBDSQR -* - END diff --git a/ext/lapack/dgbcon.f b/ext/lapack/dgbcon.f deleted file mode 100644 index ba613b735..000000000 --- a/ext/lapack/dgbcon.f +++ /dev/null @@ -1,222 +0,0 @@ - SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, - $ WORK, IWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER INFO, KL, KU, LDAB, N - DOUBLE PRECISION ANORM, RCOND -* .. -* .. Array Arguments .. - INTEGER IPIV( * ), IWORK( * ) - DOUBLE PRECISION AB( LDAB, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGBCON estimates the reciprocal of the condition number of a real -* general band matrix A, in either the 1-norm or the infinity-norm, -* using the LU factorization computed by DGBTRF. -* -* An estimate is obtained for norm(inv(A)), and the reciprocal of the -* condition number is computed as -* RCOND = 1 / ( norm(A) * norm(inv(A)) ). -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies whether the 1-norm condition number or the -* infinity-norm condition number is required: -* = '1' or 'O': 1-norm; -* = 'I': Infinity-norm. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* KL (input) INTEGER -* The number of subdiagonals within the band of A. KL >= 0. -* -* KU (input) INTEGER -* The number of superdiagonals within the band of A. KU >= 0. -* -* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) -* Details of the LU factorization of the band matrix A, as -* computed by DGBTRF. U is stored as an upper triangular band -* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and -* the multipliers used during the factorization are stored in -* rows KL+KU+2 to 2*KL+KU+1. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices; for 1 <= i <= N, row i of the matrix was -* interchanged with row IPIV(i). -* -* ANORM (input) DOUBLE PRECISION -* If NORM = '1' or 'O', the 1-norm of the original matrix A. -* If NORM = 'I', the infinity-norm of the original matrix A. -* -* RCOND (output) DOUBLE PRECISION -* The reciprocal of the condition number of the matrix A, -* computed as RCOND = 1/(norm(A) * norm(inv(A))). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) -* -* IWORK (workspace) INTEGER array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LNOTI, ONENRM - CHARACTER NORMIN - INTEGER IX, J, JP, KASE, KASE1, KD, LM - DOUBLE PRECISION AINVNM, SCALE, SMLNUM, T -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DDOT, DLAMCH - EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DLACON, DLATBS, DRSCL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) - IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN - INFO = -6 - ELSE IF( ANORM.LT.ZERO ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBCON', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - RCOND = ZERO - IF( N.EQ.0 ) THEN - RCOND = ONE - RETURN - ELSE IF( ANORM.EQ.ZERO ) THEN - RETURN - END IF -* - SMLNUM = DLAMCH( 'Safe minimum' ) -* -* Estimate the norm of inv(A). -* - AINVNM = ZERO - NORMIN = 'N' - IF( ONENRM ) THEN - KASE1 = 1 - ELSE - KASE1 = 2 - END IF - KD = KL + KU + 1 - LNOTI = KL.GT.0 - KASE = 0 - 10 CONTINUE - CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.KASE1 ) THEN -* -* Multiply by inv(L). -* - IF( LNOTI ) THEN - DO 20 J = 1, N - 1 - LM = MIN( KL, N-J ) - JP = IPIV( J ) - T = WORK( JP ) - IF( JP.NE.J ) THEN - WORK( JP ) = WORK( J ) - WORK( J ) = T - END IF - CALL DAXPY( LM, -T, AB( KD+1, J ), 1, WORK( J+1 ), 1 ) - 20 CONTINUE - END IF -* -* Multiply by inv(U). -* - CALL DLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, - $ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), - $ INFO ) - ELSE -* -* Multiply by inv(U'). -* - CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, - $ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), - $ INFO ) -* -* Multiply by inv(L'). -* - IF( LNOTI ) THEN - DO 30 J = N - 1, 1, -1 - LM = MIN( KL, N-J ) - WORK( J ) = WORK( J ) - DDOT( LM, AB( KD+1, J ), 1, - $ WORK( J+1 ), 1 ) - JP = IPIV( J ) - IF( JP.NE.J ) THEN - T = WORK( JP ) - WORK( JP ) = WORK( J ) - WORK( J ) = T - END IF - 30 CONTINUE - END IF - END IF -* -* Divide X by 1/SCALE if doing so will not cause overflow. -* - NORMIN = 'Y' - IF( SCALE.NE.ONE ) THEN - IX = IDAMAX( N, WORK, 1 ) - IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) - $ GO TO 40 - CALL DRSCL( N, SCALE, WORK, 1 ) - END IF - GO TO 10 - END IF -* -* Compute the estimate of the reciprocal condition number. -* - IF( AINVNM.NE.ZERO ) - $ RCOND = ( ONE / AINVNM ) / ANORM -* - 40 CONTINUE - RETURN -* -* End of DGBCON -* - END diff --git a/ext/lapack/dgbequ.f b/ext/lapack/dgbequ.f deleted file mode 100644 index 309798c98..000000000 --- a/ext/lapack/dgbequ.f +++ /dev/null @@ -1,240 +0,0 @@ - SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, - $ AMAX, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - INTEGER INFO, KL, KU, LDAB, M, N - DOUBLE PRECISION AMAX, COLCND, ROWCND -* .. -* .. Array Arguments .. - DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * ) -* .. -* -* Purpose -* ======= -* -* DGBEQU computes row and column scalings intended to equilibrate an -* M-by-N band matrix A and reduce its condition number. R returns the -* row scale factors and C the column scale factors, chosen to try to -* make the largest element in each row and column of the matrix B with -* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. -* -* R(i) and C(j) are restricted to be between SMLNUM = smallest safe -* number and BIGNUM = largest safe number. Use of these scaling -* factors is not guaranteed to reduce the condition number of A but -* works well in practice. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* KL (input) INTEGER -* The number of subdiagonals within the band of A. KL >= 0. -* -* KU (input) INTEGER -* The number of superdiagonals within the band of A. KU >= 0. -* -* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) -* The band matrix A, stored in rows 1 to KL+KU+1. The j-th -* column of A is stored in the j-th column of the array AB as -* follows: -* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl). -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= KL+KU+1. -* -* R (output) DOUBLE PRECISION array, dimension (M) -* If INFO = 0, or INFO > M, R contains the row scale factors -* for A. -* -* C (output) DOUBLE PRECISION array, dimension (N) -* If INFO = 0, C contains the column scale factors for A. -* -* ROWCND (output) DOUBLE PRECISION -* If INFO = 0 or INFO > M, ROWCND contains the ratio of the -* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and -* AMAX is neither too large nor too small, it is not worth -* scaling by R. -* -* COLCND (output) DOUBLE PRECISION -* If INFO = 0, COLCND contains the ratio of the smallest -* C(i) to the largest C(i). If COLCND >= 0.1, it is not -* worth scaling by C. -* -* AMAX (output) DOUBLE PRECISION -* Absolute value of largest matrix element. If AMAX is very -* close to overflow or very close to underflow, the matrix -* should be scaled. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, and i is -* <= M: the i-th row of A is exactly zero -* > M: the (i-M)-th column of A is exactly zero -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, KD - DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.KL+KU+1 ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBEQU', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - ROWCND = ONE - COLCND = ONE - AMAX = ZERO - RETURN - END IF -* -* Get machine constants. -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM -* -* Compute row scale factors. -* - DO 10 I = 1, M - R( I ) = ZERO - 10 CONTINUE -* -* Find the maximum element in each row. -* - KD = KU + 1 - DO 30 J = 1, N - DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M ) - R( I ) = MAX( R( I ), ABS( AB( KD+I-J, J ) ) ) - 20 CONTINUE - 30 CONTINUE -* -* Find the maximum and minimum scale factors. -* - RCMIN = BIGNUM - RCMAX = ZERO - DO 40 I = 1, M - RCMAX = MAX( RCMAX, R( I ) ) - RCMIN = MIN( RCMIN, R( I ) ) - 40 CONTINUE - AMAX = RCMAX -* - IF( RCMIN.EQ.ZERO ) THEN -* -* Find the first zero scale factor and return an error code. -* - DO 50 I = 1, M - IF( R( I ).EQ.ZERO ) THEN - INFO = I - RETURN - END IF - 50 CONTINUE - ELSE -* -* Invert the scale factors. -* - DO 60 I = 1, M - R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) - 60 CONTINUE -* -* Compute ROWCND = min(R(I)) / max(R(I)) -* - ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) - END IF -* -* Compute column scale factors -* - DO 70 J = 1, N - C( J ) = ZERO - 70 CONTINUE -* -* Find the maximum element in each column, -* assuming the row scaling computed above. -* - KD = KU + 1 - DO 90 J = 1, N - DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M ) - C( J ) = MAX( C( J ), ABS( AB( KD+I-J, J ) )*R( I ) ) - 80 CONTINUE - 90 CONTINUE -* -* Find the maximum and minimum scale factors. -* - RCMIN = BIGNUM - RCMAX = ZERO - DO 100 J = 1, N - RCMIN = MIN( RCMIN, C( J ) ) - RCMAX = MAX( RCMAX, C( J ) ) - 100 CONTINUE -* - IF( RCMIN.EQ.ZERO ) THEN -* -* Find the first zero scale factor and return an error code. -* - DO 110 J = 1, N - IF( C( J ).EQ.ZERO ) THEN - INFO = M + J - RETURN - END IF - 110 CONTINUE - ELSE -* -* Invert the scale factors. -* - DO 120 J = 1, N - C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) - 120 CONTINUE -* -* Compute COLCND = min(C(J)) / max(C(J)) -* - COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) - END IF -* - RETURN -* -* End of DGBEQU -* - END diff --git a/ext/lapack/dgbsv.f b/ext/lapack/dgbsv.f deleted file mode 100644 index e2d8b5ebd..000000000 --- a/ext/lapack/dgbsv.f +++ /dev/null @@ -1,144 +0,0 @@ - SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) -* -* -- LAPACK driver routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGBSV computes the solution to a real system of linear equations -* A * X = B, where A is a band matrix of order N with KL subdiagonals -* and KU superdiagonals, and X and B are N-by-NRHS matrices. -* -* The LU decomposition with partial pivoting and row interchanges is -* used to factor A as A = L * U, where L is a product of permutation -* and unit lower triangular matrices with KL subdiagonals, and U is -* upper triangular with KL+KU superdiagonals. The factored form of A -* is then used to solve the system of equations A * X = B. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of linear equations, i.e., the order of the -* matrix A. N >= 0. -* -* KL (input) INTEGER -* The number of subdiagonals within the band of A. KL >= 0. -* -* KU (input) INTEGER -* The number of superdiagonals within the band of A. KU >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) -* On entry, the matrix A in band storage, in rows KL+1 to -* 2*KL+KU+1; rows 1 to KL of the array need not be set. -* The j-th column of A is stored in the j-th column of the -* array AB as follows: -* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL) -* On exit, details of the factorization: U is stored as an -* upper triangular band matrix with KL+KU superdiagonals in -* rows 1 to KL+KU+1, and the multipliers used during the -* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. -* See below for further details. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -* -* IPIV (output) INTEGER array, dimension (N) -* The pivot indices that define the permutation matrix P; -* row i of the matrix was interchanged with row IPIV(i). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the N-by-NRHS right hand side matrix B. -* On exit, if INFO = 0, the N-by-NRHS solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and the solution has not been computed. -* -* Further Details -* =============== -* -* The band storage scheme is illustrated by the following example, when -* M = N = 6, KL = 2, KU = 1: -* -* On entry: On exit: -* -* * * * + + + * * * u14 u25 u36 -* * * + + + + * * u13 u24 u35 u46 -* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 -* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 -* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * -* a31 a42 a53 a64 * * m31 m42 m53 m64 * * -* -* Array elements marked * are not used by the routine; elements marked -* + need not be set on entry, but are required by the routine to store -* elements of U because of fill-in resulting from the row interchanges. -* -* ===================================================================== -* -* .. External Subroutines .. - EXTERNAL DGBTRF, DGBTRS, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( KL.LT.0 ) THEN - INFO = -2 - ELSE IF( KU.LT.0 ) THEN - INFO = -3 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN - INFO = -6 - ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBSV ', -INFO ) - RETURN - END IF -* -* Compute the LU factorization of the band matrix A. -* - CALL DGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO ) - IF( INFO.EQ.0 ) THEN -* -* Solve the system A*X = B, overwriting B with X. -* - CALL DGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV, - $ B, LDB, INFO ) - END IF - RETURN -* -* End of DGBSV -* - END diff --git a/ext/lapack/dgbtf2.f b/ext/lapack/dgbtf2.f deleted file mode 100644 index 5e25629fc..000000000 --- a/ext/lapack/dgbtf2.f +++ /dev/null @@ -1,203 +0,0 @@ - SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, KL, KU, LDAB, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION AB( LDAB, * ) -* .. -* -* Purpose -* ======= -* -* DGBTF2 computes an LU factorization of a real m-by-n band matrix A -* using partial pivoting with row interchanges. -* -* This is the unblocked version of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* KL (input) INTEGER -* The number of subdiagonals within the band of A. KL >= 0. -* -* KU (input) INTEGER -* The number of superdiagonals within the band of A. KU >= 0. -* -* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) -* On entry, the matrix A in band storage, in rows KL+1 to -* 2*KL+KU+1; rows 1 to KL of the array need not be set. -* The j-th column of A is stored in the j-th column of the -* array AB as follows: -* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) -* -* On exit, details of the factorization: U is stored as an -* upper triangular band matrix with KL+KU superdiagonals in -* rows 1 to KL+KU+1, and the multipliers used during the -* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. -* See below for further details. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* Further Details -* =============== -* -* The band storage scheme is illustrated by the following example, when -* M = N = 6, KL = 2, KU = 1: -* -* On entry: On exit: -* -* * * * + + + * * * u14 u25 u36 -* * * + + + + * * u13 u24 u35 u46 -* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 -* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 -* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * -* a31 a42 a53 a64 * * m31 m42 m53 m64 * * -* -* Array elements marked * are not used by the routine; elements marked -* + need not be set on entry, but are required by the routine to store -* elements of U, because of fill-in resulting from the row -* interchanges. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, JP, JU, KM, KV -* .. -* .. External Functions .. - INTEGER IDAMAX - EXTERNAL IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DGER, DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* KV is the number of superdiagonals in the factor U, allowing for -* fill-in. -* - KV = KU + KL -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.KL+KV+1 ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBTF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Gaussian elimination with partial pivoting -* -* Set fill-in elements in columns KU+2 to KV to zero. -* - DO 20 J = KU + 2, MIN( KV, N ) - DO 10 I = KV - J + 2, KL - AB( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* -* JU is the index of the last column affected by the current stage -* of the factorization. -* - JU = 1 -* - DO 40 J = 1, MIN( M, N ) -* -* Set fill-in elements in column J+KV to zero. -* - IF( J+KV.LE.N ) THEN - DO 30 I = 1, KL - AB( I, J+KV ) = ZERO - 30 CONTINUE - END IF -* -* Find pivot and test for singularity. KM is the number of -* subdiagonal elements in the current column. -* - KM = MIN( KL, M-J ) - JP = IDAMAX( KM+1, AB( KV+1, J ), 1 ) - IPIV( J ) = JP + J - 1 - IF( AB( KV+JP, J ).NE.ZERO ) THEN - JU = MAX( JU, MIN( J+KU+JP-1, N ) ) -* -* Apply interchange to columns J to JU. -* - IF( JP.NE.1 ) - $ CALL DSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1, - $ AB( KV+1, J ), LDAB-1 ) -* - IF( KM.GT.0 ) THEN -* -* Compute multipliers. -* - CALL DSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 ) -* -* Update trailing submatrix within the band. -* - IF( JU.GT.J ) - $ CALL DGER( KM, JU-J, -ONE, AB( KV+2, J ), 1, - $ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ), - $ LDAB-1 ) - END IF - ELSE -* -* If pivot is zero, set INFO to the index of the pivot -* unless a zero pivot has already been found. -* - IF( INFO.EQ.0 ) - $ INFO = J - END IF - 40 CONTINUE - RETURN -* -* End of DGBTF2 -* - END diff --git a/ext/lapack/dgbtrf.f b/ext/lapack/dgbtrf.f deleted file mode 100644 index c6e3d0a9c..000000000 --- a/ext/lapack/dgbtrf.f +++ /dev/null @@ -1,442 +0,0 @@ - SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, KL, KU, LDAB, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION AB( LDAB, * ) -* .. -* -* Purpose -* ======= -* -* DGBTRF computes an LU factorization of a real m-by-n band matrix A -* using partial pivoting with row interchanges. -* -* This is the blocked version of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* KL (input) INTEGER -* The number of subdiagonals within the band of A. KL >= 0. -* -* KU (input) INTEGER -* The number of superdiagonals within the band of A. KU >= 0. -* -* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N) -* On entry, the matrix A in band storage, in rows KL+1 to -* 2*KL+KU+1; rows 1 to KL of the array need not be set. -* The j-th column of A is stored in the j-th column of the -* array AB as follows: -* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl) -* -* On exit, details of the factorization: U is stored as an -* upper triangular band matrix with KL+KU superdiagonals in -* rows 1 to KL+KU+1, and the multipliers used during the -* factorization are stored in rows KL+KU+2 to 2*KL+KU+1. -* See below for further details. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* Further Details -* =============== -* -* The band storage scheme is illustrated by the following example, when -* M = N = 6, KL = 2, KU = 1: -* -* On entry: On exit: -* -* * * * + + + * * * u14 u25 u36 -* * * + + + + * * u13 u24 u35 u46 -* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 -* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 -* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * -* a31 a42 a53 a64 * * m31 m42 m53 m64 * * -* -* Array elements marked * are not used by the routine; elements marked -* + need not be set on entry, but are required by the routine to store -* elements of U because of fill-in resulting from the row interchanges. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) - INTEGER NBMAX, LDWORK - PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 ) -* .. -* .. Local Scalars .. - INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP, - $ JU, K2, KM, KV, NB, NW - DOUBLE PRECISION TEMP -* .. -* .. Local Arrays .. - DOUBLE PRECISION WORK13( LDWORK, NBMAX ), - $ WORK31( LDWORK, NBMAX ) -* .. -* .. External Functions .. - INTEGER IDAMAX, ILAENV - EXTERNAL IDAMAX, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGBTF2, DGEMM, DGER, DLASWP, DSCAL, - $ DSWAP, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* KV is the number of superdiagonals in the factor U, allowing for -* fill-in -* - KV = KU + KL -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( LDAB.LT.KL+KV+1 ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment -* - NB = ILAENV( 1, 'DGBTRF', ' ', M, N, KL, KU ) -* -* The block size must not exceed the limit set by the size of the -* local arrays WORK13 and WORK31. -* - NB = MIN( NB, NBMAX ) -* - IF( NB.LE.1 .OR. NB.GT.KL ) THEN -* -* Use unblocked code -* - CALL DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) - ELSE -* -* Use blocked code -* -* Zero the superdiagonal elements of the work array WORK13 -* - DO 20 J = 1, NB - DO 10 I = 1, J - 1 - WORK13( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE -* -* Zero the subdiagonal elements of the work array WORK31 -* - DO 40 J = 1, NB - DO 30 I = J + 1, NB - WORK31( I, J ) = ZERO - 30 CONTINUE - 40 CONTINUE -* -* Gaussian elimination with partial pivoting -* -* Set fill-in elements in columns KU+2 to KV to zero -* - DO 60 J = KU + 2, MIN( KV, N ) - DO 50 I = KV - J + 2, KL - AB( I, J ) = ZERO - 50 CONTINUE - 60 CONTINUE -* -* JU is the index of the last column affected by the current -* stage of the factorization -* - JU = 1 -* - DO 180 J = 1, MIN( M, N ), NB - JB = MIN( NB, MIN( M, N )-J+1 ) -* -* The active part of the matrix is partitioned -* -* A11 A12 A13 -* A21 A22 A23 -* A31 A32 A33 -* -* Here A11, A21 and A31 denote the current block of JB columns -* which is about to be factorized. The number of rows in the -* partitioning are JB, I2, I3 respectively, and the numbers -* of columns are JB, J2, J3. The superdiagonal elements of A13 -* and the subdiagonal elements of A31 lie outside the band. -* - I2 = MIN( KL-JB, M-J-JB+1 ) - I3 = MIN( JB, M-J-KL+1 ) -* -* J2 and J3 are computed after JU has been updated. -* -* Factorize the current block of JB columns -* - DO 80 JJ = J, J + JB - 1 -* -* Set fill-in elements in column JJ+KV to zero -* - IF( JJ+KV.LE.N ) THEN - DO 70 I = 1, KL - AB( I, JJ+KV ) = ZERO - 70 CONTINUE - END IF -* -* Find pivot and test for singularity. KM is the number of -* subdiagonal elements in the current column. -* - KM = MIN( KL, M-JJ ) - JP = IDAMAX( KM+1, AB( KV+1, JJ ), 1 ) - IPIV( JJ ) = JP + JJ - J - IF( AB( KV+JP, JJ ).NE.ZERO ) THEN - JU = MAX( JU, MIN( JJ+KU+JP-1, N ) ) - IF( JP.NE.1 ) THEN -* -* Apply interchange to columns J to J+JB-1 -* - IF( JP+JJ-1.LT.J+KL ) THEN -* - CALL DSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, - $ AB( KV+JP+JJ-J, J ), LDAB-1 ) - ELSE -* -* The interchange affects columns J to JJ-1 of A31 -* which are stored in the work array WORK31 -* - CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, - $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) - CALL DSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1, - $ AB( KV+JP, JJ ), LDAB-1 ) - END IF - END IF -* -* Compute multipliers -* - CALL DSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ), - $ 1 ) -* -* Update trailing submatrix within the band and within -* the current block. JM is the index of the last column -* which needs to be updated. -* - JM = MIN( JU, J+JB-1 ) - IF( JM.GT.JJ ) - $ CALL DGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1, - $ AB( KV, JJ+1 ), LDAB-1, - $ AB( KV+1, JJ+1 ), LDAB-1 ) - ELSE -* -* If pivot is zero, set INFO to the index of the pivot -* unless a zero pivot has already been found. -* - IF( INFO.EQ.0 ) - $ INFO = JJ - END IF -* -* Copy current column of A31 into the work array WORK31 -* - NW = MIN( JJ-J+1, I3 ) - IF( NW.GT.0 ) - $ CALL DCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1, - $ WORK31( 1, JJ-J+1 ), 1 ) - 80 CONTINUE - IF( J+JB.LE.N ) THEN -* -* Apply the row interchanges to the other blocks. -* - J2 = MIN( JU-J+1, KV ) - JB - J3 = MAX( 0, JU-J-KV+1 ) -* -* Use DLASWP to apply the row interchanges to A12, A22, and -* A32. -* - CALL DLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB, - $ IPIV( J ), 1 ) -* -* Adjust the pivot indices. -* - DO 90 I = J, J + JB - 1 - IPIV( I ) = IPIV( I ) + J - 1 - 90 CONTINUE -* -* Apply the row interchanges to A13, A23, and A33 -* columnwise. -* - K2 = J - 1 + JB + J2 - DO 110 I = 1, J3 - JJ = K2 + I - DO 100 II = J + I - 1, J + JB - 1 - IP = IPIV( II ) - IF( IP.NE.II ) THEN - TEMP = AB( KV+1+II-JJ, JJ ) - AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ ) - AB( KV+1+IP-JJ, JJ ) = TEMP - END IF - 100 CONTINUE - 110 CONTINUE -* -* Update the relevant part of the trailing submatrix -* - IF( J2.GT.0 ) THEN -* -* Update A12 -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, J2, ONE, AB( KV+1, J ), LDAB-1, - $ AB( KV+1-JB, J+JB ), LDAB-1 ) -* - IF( I2.GT.0 ) THEN -* -* Update A22 -* - CALL DGEMM( 'No transpose', 'No transpose', I2, J2, - $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, - $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, - $ AB( KV+1, J+JB ), LDAB-1 ) - END IF -* - IF( I3.GT.0 ) THEN -* -* Update A32 -* - CALL DGEMM( 'No transpose', 'No transpose', I3, J2, - $ JB, -ONE, WORK31, LDWORK, - $ AB( KV+1-JB, J+JB ), LDAB-1, ONE, - $ AB( KV+KL+1-JB, J+JB ), LDAB-1 ) - END IF - END IF -* - IF( J3.GT.0 ) THEN -* -* Copy the lower triangle of A13 into the work array -* WORK13 -* - DO 130 JJ = 1, J3 - DO 120 II = JJ, JB - WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 ) - 120 CONTINUE - 130 CONTINUE -* -* Update A13 in the work array -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', - $ JB, J3, ONE, AB( KV+1, J ), LDAB-1, - $ WORK13, LDWORK ) -* - IF( I2.GT.0 ) THEN -* -* Update A23 -* - CALL DGEMM( 'No transpose', 'No transpose', I2, J3, - $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1, - $ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ), - $ LDAB-1 ) - END IF -* - IF( I3.GT.0 ) THEN -* -* Update A33 -* - CALL DGEMM( 'No transpose', 'No transpose', I3, J3, - $ JB, -ONE, WORK31, LDWORK, WORK13, - $ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 ) - END IF -* -* Copy the lower triangle of A13 back into place -* - DO 150 JJ = 1, J3 - DO 140 II = JJ, JB - AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ ) - 140 CONTINUE - 150 CONTINUE - END IF - ELSE -* -* Adjust the pivot indices. -* - DO 160 I = J, J + JB - 1 - IPIV( I ) = IPIV( I ) + J - 1 - 160 CONTINUE - END IF -* -* Partially undo the interchanges in the current block to -* restore the upper triangular form of A31 and copy the upper -* triangle of A31 back into place -* - DO 170 JJ = J + JB - 1, J, -1 - JP = IPIV( JJ ) - JJ + 1 - IF( JP.NE.1 ) THEN -* -* Apply interchange to columns J to JJ-1 -* - IF( JP+JJ-1.LT.J+KL ) THEN -* -* The interchange does not affect A31 -* - CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, - $ AB( KV+JP+JJ-J, J ), LDAB-1 ) - ELSE -* -* The interchange does affect A31 -* - CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1, - $ WORK31( JP+JJ-J-KL, 1 ), LDWORK ) - END IF - END IF -* -* Copy the current column of A31 back into place -* - NW = MIN( I3, JJ-J+1 ) - IF( NW.GT.0 ) - $ CALL DCOPY( NW, WORK31( 1, JJ-J+1 ), 1, - $ AB( KV+KL+1-JJ+J, JJ ), 1 ) - 170 CONTINUE - 180 CONTINUE - END IF -* - RETURN -* -* End of DGBTRF -* - END diff --git a/ext/lapack/dgbtrs.f b/ext/lapack/dgbtrs.f deleted file mode 100644 index 26fdf91eb..000000000 --- a/ext/lapack/dgbtrs.f +++ /dev/null @@ -1,187 +0,0 @@ - SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, - $ INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGBTRS solves a system of linear equations -* A * X = B or A' * X = B -* with a general band matrix A using the LU factorization computed -* by DGBTRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations. -* = 'N': A * X = B (No transpose) -* = 'T': A'* X = B (Transpose) -* = 'C': A'* X = B (Conjugate transpose = Transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* KL (input) INTEGER -* The number of subdiagonals within the band of A. KL >= 0. -* -* KU (input) INTEGER -* The number of superdiagonals within the band of A. KU >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) -* Details of the LU factorization of the band matrix A, as -* computed by DGBTRF. U is stored as an upper triangular band -* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and -* the multipliers used during the factorization are stored in -* rows KL+KU+2 to 2*KL+KU+1. -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= 2*KL+KU+1. -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices; for 1 <= i <= N, row i of the matrix was -* interchanged with row IPIV(i). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LNOTI, NOTRAN - INTEGER I, J, KD, L, LM -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DGER, DSWAP, DTBSV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( KL.LT.0 ) THEN - INFO = -3 - ELSE IF( KU.LT.0 ) THEN - INFO = -4 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -5 - ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGBTRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - KD = KU + KL + 1 - LNOTI = KL.GT.0 -* - IF( NOTRAN ) THEN -* -* Solve A*X = B. -* -* Solve L*X = B, overwriting B with X. -* -* L is represented as a product of permutations and unit lower -* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), -* where each transformation L(i) is a rank-one modification of -* the identity matrix. -* - IF( LNOTI ) THEN - DO 10 J = 1, N - 1 - LM = MIN( KL, N-J ) - L = IPIV( J ) - IF( L.NE.J ) - $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) - CALL DGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ), - $ LDB, B( J+1, 1 ), LDB ) - 10 CONTINUE - END IF -* - DO 20 I = 1, NRHS -* -* Solve U*X = B, overwriting B with X. -* - CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU, - $ AB, LDAB, B( 1, I ), 1 ) - 20 CONTINUE -* - ELSE -* -* Solve A'*X = B. -* - DO 30 I = 1, NRHS -* -* Solve U'*X = B, overwriting B with X. -* - CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB, - $ LDAB, B( 1, I ), 1 ) - 30 CONTINUE -* -* Solve L'*X = B, overwriting B with X. -* - IF( LNOTI ) THEN - DO 40 J = N - 1, 1, -1 - LM = MIN( KL, N-J ) - CALL DGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ), - $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB ) - L = IPIV( J ) - IF( L.NE.J ) - $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB ) - 40 CONTINUE - END IF - END IF - RETURN -* -* End of DGBTRS -* - END diff --git a/ext/lapack/dgebd2.f b/ext/lapack/dgebd2.f deleted file mode 100644 index 0bdac2d24..000000000 --- a/ext/lapack/dgebd2.f +++ /dev/null @@ -1,238 +0,0 @@ - SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), - $ TAUQ( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGEBD2 reduces a real general m by n matrix A to upper or lower -* bidiagonal form B by an orthogonal transformation: Q' * A * P = B. -* -* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows in the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns in the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n general matrix to be reduced. -* On exit, -* if m >= n, the diagonal and the first superdiagonal are -* overwritten with the upper bidiagonal matrix B; the -* elements below the diagonal, with the array TAUQ, represent -* the orthogonal matrix Q as a product of elementary -* reflectors, and the elements above the first superdiagonal, -* with the array TAUP, represent the orthogonal matrix P as -* a product of elementary reflectors; -* if m < n, the diagonal and the first subdiagonal are -* overwritten with the lower bidiagonal matrix B; the -* elements below the first subdiagonal, with the array TAUQ, -* represent the orthogonal matrix Q as a product of -* elementary reflectors, and the elements above the diagonal, -* with the array TAUP, represent the orthogonal matrix P as -* a product of elementary reflectors. -* See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* D (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The diagonal elements of the bidiagonal matrix B: -* D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) -* The off-diagonal elements of the bidiagonal matrix B: -* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; -* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. -* -* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N)) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix Q. See Further Details. -* -* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix P. See Further Details. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (max(M,N)) -* -* INFO (output) INTEGER -* = 0: successful exit. -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* The matrices Q and P are represented as products of elementary -* reflectors: -* -* If m >= n, -* -* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are real scalars, and v and u are real vectors; -* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); -* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); -* tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* If m < n, -* -* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are real scalars, and v and u are real vectors; -* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); -* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); -* tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* The contents of A on exit are illustrated by the following examples: -* -* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -* -* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) -* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) -* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) -* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) -* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) -* ( v1 v2 v3 v4 v5 ) -* -* where d and e denote diagonal and off-diagonal elements of B, vi -* denotes an element of the vector defining H(i), and ui an element of -* the vector defining G(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.LT.0 ) THEN - CALL XERBLA( 'DGEBD2', -INFO ) - RETURN - END IF -* - IF( M.GE.N ) THEN -* -* Reduce to upper bidiagonal form -* - DO 10 I = 1, N -* -* Generate elementary reflector H(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAUQ( I ) ) - D( I ) = A( I, I ) - A( I, I ) = ONE -* -* Apply H(i) to A(i:m,i+1:n) from the left -* - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = D( I ) -* - IF( I.LT.N ) THEN -* -* Generate elementary reflector G(i) to annihilate -* A(i,i+2:n) -* - CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), - $ LDA, TAUP( I ) ) - E( I ) = A( I, I+1 ) - A( I, I+1 ) = ONE -* -* Apply G(i) to A(i+1:m,i+1:n) from the right -* - CALL DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA, - $ TAUP( I ), A( I+1, I+1 ), LDA, WORK ) - A( I, I+1 ) = E( I ) - ELSE - TAUP( I ) = ZERO - END IF - 10 CONTINUE - ELSE -* -* Reduce to lower bidiagonal form -* - DO 20 I = 1, M -* -* Generate elementary reflector G(i) to annihilate A(i,i+1:n) -* - CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, - $ TAUP( I ) ) - D( I ) = A( I, I ) - A( I, I ) = ONE -* -* Apply G(i) to A(i+1:m,i:n) from the right -* - CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAUP( I ), - $ A( MIN( I+1, M ), I ), LDA, WORK ) - A( I, I ) = D( I ) -* - IF( I.LT.M ) THEN -* -* Generate elementary reflector H(i) to annihilate -* A(i+2:m,i) -* - CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, - $ TAUQ( I ) ) - E( I ) = A( I+1, I ) - A( I+1, I ) = ONE -* -* Apply H(i) to A(i+1:m,i+1:n) from the left -* - CALL DLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ), - $ A( I+1, I+1 ), LDA, WORK ) - A( I+1, I ) = E( I ) - ELSE - TAUQ( I ) = ZERO - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGEBD2 -* - END diff --git a/ext/lapack/dgebrd.f b/ext/lapack/dgebrd.f deleted file mode 100644 index 5ccaed3f5..000000000 --- a/ext/lapack/dgebrd.f +++ /dev/null @@ -1,258 +0,0 @@ - SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, - $ INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), - $ TAUQ( * ), WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DGEBRD reduces a general real M-by-N matrix A to upper or lower -* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. -* -* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows in the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns in the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N general matrix to be reduced. -* On exit, -* if m >= n, the diagonal and the first superdiagonal are -* overwritten with the upper bidiagonal matrix B; the -* elements below the diagonal, with the array TAUQ, represent -* the orthogonal matrix Q as a product of elementary -* reflectors, and the elements above the first superdiagonal, -* with the array TAUP, represent the orthogonal matrix P as -* a product of elementary reflectors; -* if m < n, the diagonal and the first subdiagonal are -* overwritten with the lower bidiagonal matrix B; the -* elements below the first subdiagonal, with the array TAUQ, -* represent the orthogonal matrix Q as a product of -* elementary reflectors, and the elements above the diagonal, -* with the array TAUP, represent the orthogonal matrix P as -* a product of elementary reflectors. -* See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* D (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The diagonal elements of the bidiagonal matrix B: -* D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1) -* The off-diagonal elements of the bidiagonal matrix B: -* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; -* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. -* -* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N)) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix Q. See Further Details. -* -* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix P. See Further Details. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The length of the array WORK. LWORK >= max(1,M,N). -* For optimum performance LWORK >= (M+N)*NB, where NB -* is the optimal blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* -* Further Details -* =============== -* -* The matrices Q and P are represented as products of elementary -* reflectors: -* -* If m >= n, -* -* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are real scalars, and v and u are real vectors; -* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i); -* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n); -* tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* If m < n, -* -* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are real scalars, and v and u are real vectors; -* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); -* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); -* tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* The contents of A on exit are illustrated by the following examples: -* -* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -* -* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) -* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) -* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) -* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) -* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) -* ( v1 v2 v3 v4 v5 ) -* -* where d and e denote diagonal and off-diagonal elements of B, vi -* denotes an element of the vector defining H(i), and ui an element of -* the vector defining G(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, LDWRKX, LDWRKY, MINMN, NB, NBMIN, - $ NX - DOUBLE PRECISION WS -* .. -* .. External Subroutines .. - EXTERNAL DGEBD2, DGEMM, DLABRD, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, M, N ) ) THEN - INFO = -10 - END IF - IF( INFO.LT.0 ) THEN - CALL XERBLA( 'DGEBRD', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - MINMN = MIN( M, N ) - IF( MINMN.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - WS = MAX( M, N ) - LDWRKX = M - LDWRKY = N -* -* Set the block size NB and the crossover point NX. -* - NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) ) -* - IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN -* -* Determine when to switch from blocked to unblocked code. -* - NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) ) - IF( NX.LT.MINMN ) THEN - WS = ( M+N )*NB - IF( LWORK.LT.WS ) THEN -* -* Not enough work space for the optimal NB, consider using -* a smaller block size. -* - NBMIN = ILAENV( 2, 'DGEBRD', ' ', M, N, -1, -1 ) - IF( LWORK.GE.( M+N )*NBMIN ) THEN - NB = LWORK / ( M+N ) - ELSE - NB = 1 - NX = MINMN - END IF - END IF - END IF - ELSE - NX = MINMN - END IF -* - DO 30 I = 1, MINMN - NX, NB -* -* Reduce rows and columns i:i+nb-1 to bidiagonal form and return -* the matrices X and Y which are needed to update the unreduced -* part of the matrix -* - CALL DLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ), - $ TAUQ( I ), TAUP( I ), WORK, LDWRKX, - $ WORK( LDWRKX*NB+1 ), LDWRKY ) -* -* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update -* of the form A := A - V*Y' - X*U' -* - CALL DGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1, - $ NB, -ONE, A( I+NB, I ), LDA, - $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE, - $ A( I+NB, I+NB ), LDA ) - CALL DGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1, - $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA, - $ ONE, A( I+NB, I+NB ), LDA ) -* -* Copy diagonal and off-diagonal elements of B back into A -* - IF( M.GE.N ) THEN - DO 10 J = I, I + NB - 1 - A( J, J ) = D( J ) - A( J, J+1 ) = E( J ) - 10 CONTINUE - ELSE - DO 20 J = I, I + NB - 1 - A( J, J ) = D( J ) - A( J+1, J ) = E( J ) - 20 CONTINUE - END IF - 30 CONTINUE -* -* Use unblocked code to reduce the remainder of the matrix -* - CALL DGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ), - $ TAUQ( I ), TAUP( I ), WORK, IINFO ) - WORK( 1 ) = WS - RETURN -* -* End of DGEBRD -* - END diff --git a/ext/lapack/dgecon.f b/ext/lapack/dgecon.f deleted file mode 100644 index f6bd485f4..000000000 --- a/ext/lapack/dgecon.f +++ /dev/null @@ -1,181 +0,0 @@ - SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, - $ INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER INFO, LDA, N - DOUBLE PRECISION ANORM, RCOND -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGECON estimates the reciprocal of the condition number of a general -* real matrix A, in either the 1-norm or the infinity-norm, using -* the LU factorization computed by DGETRF. -* -* An estimate is obtained for norm(inv(A)), and the reciprocal of the -* condition number is computed as -* RCOND = 1 / ( norm(A) * norm(inv(A)) ). -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies whether the 1-norm condition number or the -* infinity-norm condition number is required: -* = '1' or 'O': 1-norm; -* = 'I': Infinity-norm. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The factors L and U from the factorization A = P*L*U -* as computed by DGETRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* ANORM (input) DOUBLE PRECISION -* If NORM = '1' or 'O', the 1-norm of the original matrix A. -* If NORM = 'I', the infinity-norm of the original matrix A. -* -* RCOND (output) DOUBLE PRECISION -* The reciprocal of the condition number of the matrix A, -* computed as RCOND = 1/(norm(A) * norm(inv(A))). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (4*N) -* -* IWORK (workspace) INTEGER array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL ONENRM - CHARACTER NORMIN - INTEGER IX, KASE, KASE1 - DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, IDAMAX, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLACON, DLATRS, DRSCL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) - IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - ELSE IF( ANORM.LT.ZERO ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGECON', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - RCOND = ZERO - IF( N.EQ.0 ) THEN - RCOND = ONE - RETURN - ELSE IF( ANORM.EQ.ZERO ) THEN - RETURN - END IF -* - SMLNUM = DLAMCH( 'Safe minimum' ) -* -* Estimate the norm of inv(A). -* - AINVNM = ZERO - NORMIN = 'N' - IF( ONENRM ) THEN - KASE1 = 1 - ELSE - KASE1 = 2 - END IF - KASE = 0 - 10 CONTINUE - CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.KASE1 ) THEN -* -* Multiply by inv(L). -* - CALL DLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A, - $ LDA, WORK, SL, WORK( 2*N+1 ), INFO ) -* -* Multiply by inv(U). -* - CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N, - $ A, LDA, WORK, SU, WORK( 3*N+1 ), INFO ) - ELSE -* -* Multiply by inv(U'). -* - CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A, - $ LDA, WORK, SU, WORK( 3*N+1 ), INFO ) -* -* Multiply by inv(L'). -* - CALL DLATRS( 'Lower', 'Transpose', 'Unit', NORMIN, N, A, - $ LDA, WORK, SL, WORK( 2*N+1 ), INFO ) - END IF -* -* Divide X by 1/(SL*SU) if doing so will not cause overflow. -* - SCALE = SL*SU - NORMIN = 'Y' - IF( SCALE.NE.ONE ) THEN - IX = IDAMAX( N, WORK, 1 ) - IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO ) - $ GO TO 20 - CALL DRSCL( N, SCALE, WORK, 1 ) - END IF - GO TO 10 - END IF -* -* Compute the estimate of the reciprocal condition number. -* - IF( AINVNM.NE.ZERO ) - $ RCOND = ( ONE / AINVNM ) / ANORM -* - 20 CONTINUE - RETURN -* -* End of DGECON -* - END diff --git a/ext/lapack/dgeequ.f b/ext/lapack/dgeequ.f deleted file mode 100644 index a1be3c169..000000000 --- a/ext/lapack/dgeequ.f +++ /dev/null @@ -1,226 +0,0 @@ - SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, - $ INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N - DOUBLE PRECISION AMAX, COLCND, ROWCND -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( * ), R( * ) -* .. -* -* Purpose -* ======= -* -* DGEEQU computes row and column scalings intended to equilibrate an -* M-by-N matrix A and reduce its condition number. R returns the row -* scale factors and C the column scale factors, chosen to try to make -* the largest element in each row and column of the matrix B with -* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. -* -* R(i) and C(j) are restricted to be between SMLNUM = smallest safe -* number and BIGNUM = largest safe number. Use of these scaling -* factors is not guaranteed to reduce the condition number of A but -* works well in practice. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The M-by-N matrix whose equilibration factors are -* to be computed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* R (output) DOUBLE PRECISION array, dimension (M) -* If INFO = 0 or INFO > M, R contains the row scale factors -* for A. -* -* C (output) DOUBLE PRECISION array, dimension (N) -* If INFO = 0, C contains the column scale factors for A. -* -* ROWCND (output) DOUBLE PRECISION -* If INFO = 0 or INFO > M, ROWCND contains the ratio of the -* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and -* AMAX is neither too large nor too small, it is not worth -* scaling by R. -* -* COLCND (output) DOUBLE PRECISION -* If INFO = 0, COLCND contains the ratio of the smallest -* C(i) to the largest C(i). If COLCND >= 0.1, it is not -* worth scaling by C. -* -* AMAX (output) DOUBLE PRECISION -* Absolute value of largest matrix element. If AMAX is very -* close to overflow or very close to underflow, the matrix -* should be scaled. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, and i is -* <= M: the i-th row of A is exactly zero -* > M: the (i-M)-th column of A is exactly zero -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEEQU', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - ROWCND = ONE - COLCND = ONE - AMAX = ZERO - RETURN - END IF -* -* Get machine constants. -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM -* -* Compute row scale factors. -* - DO 10 I = 1, M - R( I ) = ZERO - 10 CONTINUE -* -* Find the maximum element in each row. -* - DO 30 J = 1, N - DO 20 I = 1, M - R( I ) = MAX( R( I ), ABS( A( I, J ) ) ) - 20 CONTINUE - 30 CONTINUE -* -* Find the maximum and minimum scale factors. -* - RCMIN = BIGNUM - RCMAX = ZERO - DO 40 I = 1, M - RCMAX = MAX( RCMAX, R( I ) ) - RCMIN = MIN( RCMIN, R( I ) ) - 40 CONTINUE - AMAX = RCMAX -* - IF( RCMIN.EQ.ZERO ) THEN -* -* Find the first zero scale factor and return an error code. -* - DO 50 I = 1, M - IF( R( I ).EQ.ZERO ) THEN - INFO = I - RETURN - END IF - 50 CONTINUE - ELSE -* -* Invert the scale factors. -* - DO 60 I = 1, M - R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM ) - 60 CONTINUE -* -* Compute ROWCND = min(R(I)) / max(R(I)) -* - ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) - END IF -* -* Compute column scale factors -* - DO 70 J = 1, N - C( J ) = ZERO - 70 CONTINUE -* -* Find the maximum element in each column, -* assuming the row scaling computed above. -* - DO 90 J = 1, N - DO 80 I = 1, M - C( J ) = MAX( C( J ), ABS( A( I, J ) )*R( I ) ) - 80 CONTINUE - 90 CONTINUE -* -* Find the maximum and minimum scale factors. -* - RCMIN = BIGNUM - RCMAX = ZERO - DO 100 J = 1, N - RCMIN = MIN( RCMIN, C( J ) ) - RCMAX = MAX( RCMAX, C( J ) ) - 100 CONTINUE -* - IF( RCMIN.EQ.ZERO ) THEN -* -* Find the first zero scale factor and return an error code. -* - DO 110 J = 1, N - IF( C( J ).EQ.ZERO ) THEN - INFO = M + J - RETURN - END IF - 110 CONTINUE - ELSE -* -* Invert the scale factors. -* - DO 120 J = 1, N - C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM ) - 120 CONTINUE -* -* Compute COLCND = min(C(J)) / max(C(J)) -* - COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM ) - END IF -* - RETURN -* -* End of DGEEQU -* - END diff --git a/ext/lapack/dgelq2.f b/ext/lapack/dgelq2.f deleted file mode 100644 index 699a70cfe..000000000 --- a/ext/lapack/dgelq2.f +++ /dev/null @@ -1,122 +0,0 @@ - SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGELQ2 computes an LQ factorization of a real m by n matrix A: -* A = L * Q. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix A. -* On exit, the elements on and below the diagonal of the array -* contain the m by min(m,n) lower trapezoidal matrix L (L is -* lower triangular if m <= n); the elements above the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of elementary reflectors (see Further Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (M) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(k) . . . H(2) H(1), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, K - DOUBLE PRECISION AII -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGELQ2', -INFO ) - RETURN - END IF -* - K = MIN( M, N ) -* - DO 10 I = 1, K -* -* Generate elementary reflector H(i) to annihilate A(i,i+1:n) -* - CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, - $ TAU( I ) ) - IF( I.LT.M ) THEN -* -* Apply H(i) to A(i+1:m,i:n) from the right -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ), - $ A( I+1, I ), LDA, WORK ) - A( I, I ) = AII - END IF - 10 CONTINUE - RETURN -* -* End of DGELQ2 -* - END diff --git a/ext/lapack/dgelqf.f b/ext/lapack/dgelqf.f deleted file mode 100644 index 0910606a8..000000000 --- a/ext/lapack/dgelqf.f +++ /dev/null @@ -1,186 +0,0 @@ - SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DGELQF computes an LQ factorization of a real M-by-N matrix A: -* A = L * Q. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix A. -* On exit, the elements on and below the diagonal of the array -* contain the m-by-min(m,n) lower trapezoidal matrix L (L is -* lower triangular if m <= n); the elements above the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of elementary reflectors (see Further Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,M). -* For optimum performance LWORK >= M*NB, where NB is the -* optimal blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(k) . . . H(2) H(1), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, K, LDWORK, NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DGELQ2, DLARFB, DLARFT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, M ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGELQF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Determine the block size. -* - NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - NBMIN = 2 - NX = 0 - IWS = M - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DGELQF', ' ', M, N, -1, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = M - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', M, N, -1, - $ -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code initially -* - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -* -* Compute the LQ factorization of the current block -* A(i:i+ib-1,i:n) -* - CALL DGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) - IF( I+IB.LE.M ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(i+ib:m,i:n) from the right -* - CALL DLARFB( 'Right', 'No transpose', 'Forward', - $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ), - $ LDA, WORK, LDWORK, A( I+IB, I ), LDA, - $ WORK( IB+1 ), LDWORK ) - END IF - 10 CONTINUE - ELSE - I = 1 - END IF -* -* Use unblocked code to factor the last or only block. -* - IF( I.LE.K ) - $ CALL DGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* - WORK( 1 ) = IWS - RETURN -* -* End of DGELQF -* - END diff --git a/ext/lapack/dgelss.f b/ext/lapack/dgelss.f deleted file mode 100644 index 36c3bb489..000000000 --- a/ext/lapack/dgelss.f +++ /dev/null @@ -1,604 +0,0 @@ - SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, - $ WORK, LWORK, INFO ) -* -* -- LAPACK driver routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK - DOUBLE PRECISION RCOND -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGELSS computes the minimum norm solution to a real linear least -* squares problem: -* -* Minimize 2-norm(| b - A*x |). -* -* using the singular value decomposition (SVD) of A. A is an M-by-N -* matrix which may be rank-deficient. -* -* Several right hand side vectors b and solution vectors x can be -* handled in a single call; they are stored as the columns of the -* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix -* X. -* -* The effective rank of A is determined by treating as zero those -* singular values which are less than RCOND times the largest singular -* value. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrices B and X. NRHS >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix A. -* On exit, the first min(m,n) rows of A are overwritten with -* its right singular vectors, stored rowwise. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the M-by-NRHS right hand side matrix B. -* On exit, B is overwritten by the N-by-NRHS solution -* matrix X. If m >= n and RANK = n, the residual -* sum-of-squares for the solution in the i-th column is given -* by the sum of squares of elements n+1:m in that column. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,max(M,N)). -* -* S (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The singular values of A in decreasing order. -* The condition number of A in the 2-norm = S(1)/S(min(m,n)). -* -* RCOND (input) DOUBLE PRECISION -* RCOND is used to determine the effective rank of A. -* Singular values S(i) <= RCOND*S(1) are treated as zero. -* If RCOND < 0, machine precision is used instead. -* -* RANK (output) INTEGER -* The effective rank of A, i.e., the number of singular values -* which are greater than RCOND*S(1). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= 1, and also: -* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS ) -* For good performance, LWORK should generally be larger. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value. -* > 0: the algorithm for computing the SVD failed to converge; -* if INFO = i, i off-diagonal elements of an intermediate -* bidiagonal form did not converge to zero. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER BDSPAC, BL, CHUNK, I, IASCL, IBSCL, IE, IL, - $ ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN, - $ MAXWRK, MINMN, MINWRK, MM, MNTHR - DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR -* .. -* .. Local Arrays .. - DOUBLE PRECISION VDUM( 1 ) -* .. -* .. External Subroutines .. - EXTERNAL DBDSQR, DCOPY, DGEBRD, DGELQF, DGEMM, DGEMV, - $ DGEQRF, DLABAD, DLACPY, DLASCL, DLASET, DORGBR, - $ DORMBR, DORMLQ, DORMQR, DRSCL, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - DOUBLE PRECISION DLAMCH, DLANGE - EXTERNAL ILAENV, DLAMCH, DLANGE -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - MINMN = MIN( M, N ) - MAXMN = MAX( M, N ) - MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -1 ) - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN - INFO = -7 - END IF -* -* Compute workspace -* (Note: Comments in the code beginning "Workspace:" describe the -* minimal amount of workspace needed at that point in the code, -* as well as the preferred amount for good performance. -* NB refers to the optimal block size for the immediately -* following subroutine, as returned by ILAENV.) -* - MINWRK = 1 - IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN - MAXWRK = 0 - MM = M - IF( M.GE.N .AND. M.GE.MNTHR ) THEN -* -* Path 1a - overdetermined, with many more rows than columns -* - MM = N - MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'DGEQRF', ' ', M, N, - $ -1, -1 ) ) - MAXWRK = MAX( MAXWRK, N+NRHS* - $ ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 ) ) - END IF - IF( M.GE.N ) THEN -* -* Path 1 - overdetermined or exactly determined -* -* Compute workspace neede for DBDSQR -* - BDSPAC = MAX( 1, 5*N-4 ) - MAXWRK = MAX( MAXWRK, 3*N+( MM+N )* - $ ILAENV( 1, 'DGEBRD', ' ', MM, N, -1, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*N+NRHS* - $ ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*N+( N-1 )* - $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) ) - MAXWRK = MAX( MAXWRK, BDSPAC ) - MAXWRK = MAX( MAXWRK, N*NRHS ) - MINWRK = MAX( 3*N+MM, 3*N+NRHS, BDSPAC ) - MAXWRK = MAX( MINWRK, MAXWRK ) - - END IF - IF( N.GT.M ) THEN -* -* Compute workspace neede for DBDSQR -* - BDSPAC = MAX( 1, 5*M-4 ) - MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC ) - IF( N.GE.MNTHR ) THEN -* -* Path 2a - underdetermined, with many more columns -* than rows -* - MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 ) - MAXWRK = MAX( MAXWRK, M*M+4*M+2*M* - $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) ) - MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS* - $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) ) - MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )* - $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) ) - MAXWRK = MAX( MAXWRK, M*M+M+BDSPAC ) - IF( NRHS.GT.1 ) THEN - MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS ) - ELSE - MAXWRK = MAX( MAXWRK, M*M+2*M ) - END IF - MAXWRK = MAX( MAXWRK, M+NRHS* - $ ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 ) ) - ELSE -* -* Path 2 - underdetermined -* - MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'DGEBRD', ' ', M, N, - $ -1, -1 ) - MAXWRK = MAX( MAXWRK, 3*M+NRHS* - $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) ) - MAXWRK = MAX( MAXWRK, 3*M+M* - $ ILAENV( 1, 'DORGBR', 'P', M, N, M, -1 ) ) - MAXWRK = MAX( MAXWRK, BDSPAC ) - MAXWRK = MAX( MAXWRK, N*NRHS ) - END IF - END IF - MAXWRK = MAX( MINWRK, MAXWRK ) - WORK( 1 ) = MAXWRK - END IF -* - MINWRK = MAX( MINWRK, 1 ) - IF( LWORK.LT.MINWRK ) - $ INFO = -12 - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGELSS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - RANK = 0 - RETURN - END IF -* -* Get machine parameters -* - EPS = DLAMCH( 'P' ) - SFMIN = DLAMCH( 'S' ) - SMLNUM = SFMIN / EPS - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -* -* Scale A if max element outside range [SMLNUM,BIGNUM] -* - ANRM = DLANGE( 'M', M, N, A, LDA, WORK ) - IASCL = 0 - IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN -* -* Scale matrix norm up to SMLNUM -* - CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO ) - IASCL = 1 - ELSE IF( ANRM.GT.BIGNUM ) THEN -* -* Scale matrix norm down to BIGNUM -* - CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO ) - IASCL = 2 - ELSE IF( ANRM.EQ.ZERO ) THEN -* -* Matrix all zero. Return zero solution. -* - CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB ) - CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 ) - RANK = 0 - GO TO 70 - END IF -* -* Scale B if max element outside range [SMLNUM,BIGNUM] -* - BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK ) - IBSCL = 0 - IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN -* -* Scale matrix norm up to SMLNUM -* - CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO ) - IBSCL = 1 - ELSE IF( BNRM.GT.BIGNUM ) THEN -* -* Scale matrix norm down to BIGNUM -* - CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO ) - IBSCL = 2 - END IF -* -* Overdetermined case -* - IF( M.GE.N ) THEN -* -* Path 1 - overdetermined or exactly determined -* - MM = M - IF( M.GE.MNTHR ) THEN -* -* Path 1a - overdetermined, with many more rows than columns -* - MM = N - ITAU = 1 - IWORK = ITAU + N -* -* Compute A=Q*R -* (Workspace: need 2*N, prefer N+N*NB) -* - CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), - $ LWORK-IWORK+1, INFO ) -* -* Multiply B by transpose(Q) -* (Workspace: need N+NRHS, prefer N+NRHS*NB) -* - CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B, - $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) -* -* Zero out below R -* - IF( N.GT.1 ) - $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA ) - END IF -* - IE = 1 - ITAUQ = IE + N - ITAUP = ITAUQ + N - IWORK = ITAUP + N -* -* Bidiagonalize R in A -* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB) -* - CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ INFO ) -* -* Multiply B by transpose of left bidiagonalizing vectors of R -* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB) -* - CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ), - $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) -* -* Generate right bidiagonalizing vectors of R in A -* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB) -* - CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, INFO ) - IWORK = IE + N -* -* Perform bidiagonal QR iteration -* multiply B by transpose of left singular vectors -* compute right singular vectors in A -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'U', N, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM, - $ 1, B, LDB, WORK( IWORK ), INFO ) - IF( INFO.NE.0 ) - $ GO TO 70 -* -* Multiply B by reciprocals of singular values -* - THR = MAX( RCOND*S( 1 ), SFMIN ) - IF( RCOND.LT.ZERO ) - $ THR = MAX( EPS*S( 1 ), SFMIN ) - RANK = 0 - DO 10 I = 1, N - IF( S( I ).GT.THR ) THEN - CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) - RANK = RANK + 1 - ELSE - CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) - END IF - 10 CONTINUE -* -* Multiply B by right singular vectors -* (Workspace: need N, prefer N*NRHS) -* - IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN - CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, A, LDA, B, LDB, ZERO, - $ WORK, LDB ) - CALL DLACPY( 'G', N, NRHS, WORK, LDB, B, LDB ) - ELSE IF( NRHS.GT.1 ) THEN - CHUNK = LWORK / N - DO 20 I = 1, NRHS, CHUNK - BL = MIN( NRHS-I+1, CHUNK ) - CALL DGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B, LDB, - $ ZERO, WORK, N ) - CALL DLACPY( 'G', N, BL, WORK, N, B, LDB ) - 20 CONTINUE - ELSE - CALL DGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 ) - CALL DCOPY( N, WORK, 1, B, 1 ) - END IF -* - ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+ - $ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN -* -* Path 2a - underdetermined, with many more columns than rows -* and sufficient workspace for an efficient algorithm -* - LDWORK = M - IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ), - $ M*LDA+M+M*NRHS ) )LDWORK = LDA - ITAU = 1 - IWORK = M + 1 -* -* Compute A=L*Q -* (Workspace: need 2*M, prefer M+M*NB) -* - CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ), - $ LWORK-IWORK+1, INFO ) - IL = IWORK -* -* Copy L to WORK(IL), zeroing out above it -* - CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK ) - CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ), - $ LDWORK ) - IE = IL + LDWORK*M - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize L in WORK(IL) -* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB) -* - CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ), - $ WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ), - $ LWORK-IWORK+1, INFO ) -* -* Multiply B by transpose of left bidiagonalizing vectors of L -* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) -* - CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK, - $ WORK( ITAUQ ), B, LDB, WORK( IWORK ), - $ LWORK-IWORK+1, INFO ) -* -* Generate right bidiagonalizing vectors of R in WORK(IL) -* (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB) -* - CALL DORGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, INFO ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, -* computing right singular vectors of L in WORK(IL) and -* multiplying B by transpose of left singular vectors -* (Workspace: need M*M+M+BDSPAC) -* - CALL DBDSQR( 'U', M, M, 0, NRHS, S, WORK( IE ), WORK( IL ), - $ LDWORK, A, LDA, B, LDB, WORK( IWORK ), INFO ) - IF( INFO.NE.0 ) - $ GO TO 70 -* -* Multiply B by reciprocals of singular values -* - THR = MAX( RCOND*S( 1 ), SFMIN ) - IF( RCOND.LT.ZERO ) - $ THR = MAX( EPS*S( 1 ), SFMIN ) - RANK = 0 - DO 30 I = 1, M - IF( S( I ).GT.THR ) THEN - CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) - RANK = RANK + 1 - ELSE - CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) - END IF - 30 CONTINUE - IWORK = IE -* -* Multiply B by right singular vectors of L in WORK(IL) -* (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS) -* - IF( LWORK.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN - CALL DGEMM( 'T', 'N', M, NRHS, M, ONE, WORK( IL ), LDWORK, - $ B, LDB, ZERO, WORK( IWORK ), LDB ) - CALL DLACPY( 'G', M, NRHS, WORK( IWORK ), LDB, B, LDB ) - ELSE IF( NRHS.GT.1 ) THEN - CHUNK = ( LWORK-IWORK+1 ) / M - DO 40 I = 1, NRHS, CHUNK - BL = MIN( NRHS-I+1, CHUNK ) - CALL DGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK, - $ B( 1, I ), LDB, ZERO, WORK( IWORK ), N ) - CALL DLACPY( 'G', M, BL, WORK( IWORK ), N, B, LDB ) - 40 CONTINUE - ELSE - CALL DGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ), - $ 1, ZERO, WORK( IWORK ), 1 ) - CALL DCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 ) - END IF -* -* Zero out below first M rows of B -* - CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB ) - IWORK = ITAU + M -* -* Multiply transpose(Q) by B -* (Workspace: need M+NRHS, prefer M+NRHS*NB) -* - CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B, - $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) -* - ELSE -* -* Path 2 - remaining underdetermined cases -* - IE = 1 - ITAUQ = IE + M - ITAUP = ITAUQ + M - IWORK = ITAUP + M -* -* Bidiagonalize A -* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB) -* - CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ), - $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1, - $ INFO ) -* -* Multiply B by transpose of left bidiagonalizing vectors -* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB) -* - CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ), - $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO ) -* -* Generate right bidiagonalizing vectors in A -* (Workspace: need 4*M, prefer 3*M+M*NB) -* - CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ), - $ WORK( IWORK ), LWORK-IWORK+1, INFO ) - IWORK = IE + M -* -* Perform bidiagonal QR iteration, -* computing right singular vectors of A in A and -* multiplying B by transpose of left singular vectors -* (Workspace: need BDSPAC) -* - CALL DBDSQR( 'L', M, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM, - $ 1, B, LDB, WORK( IWORK ), INFO ) - IF( INFO.NE.0 ) - $ GO TO 70 -* -* Multiply B by reciprocals of singular values -* - THR = MAX( RCOND*S( 1 ), SFMIN ) - IF( RCOND.LT.ZERO ) - $ THR = MAX( EPS*S( 1 ), SFMIN ) - RANK = 0 - DO 50 I = 1, M - IF( S( I ).GT.THR ) THEN - CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB ) - RANK = RANK + 1 - ELSE - CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB ) - END IF - 50 CONTINUE -* -* Multiply B by right singular vectors of A -* (Workspace: need N, prefer N*NRHS) -* - IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN - CALL DGEMM( 'T', 'N', N, NRHS, M, ONE, A, LDA, B, LDB, ZERO, - $ WORK, LDB ) - CALL DLACPY( 'F', N, NRHS, WORK, LDB, B, LDB ) - ELSE IF( NRHS.GT.1 ) THEN - CHUNK = LWORK / N - DO 60 I = 1, NRHS, CHUNK - BL = MIN( NRHS-I+1, CHUNK ) - CALL DGEMM( 'T', 'N', N, BL, M, ONE, A, LDA, B( 1, I ), - $ LDB, ZERO, WORK, N ) - CALL DLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB ) - 60 CONTINUE - ELSE - CALL DGEMV( 'T', M, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 ) - CALL DCOPY( N, WORK, 1, B, 1 ) - END IF - END IF -* -* Undo scaling -* - IF( IASCL.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO ) - CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN, - $ INFO ) - ELSE IF( IASCL.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO ) - CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN, - $ INFO ) - END IF - IF( IBSCL.EQ.1 ) THEN - CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO ) - ELSE IF( IBSCL.EQ.2 ) THEN - CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO ) - END IF -* - 70 CONTINUE - WORK( 1 ) = MAXWRK - RETURN -* -* End of DGELSS -* - END diff --git a/ext/lapack/dgeqr2.f b/ext/lapack/dgeqr2.f deleted file mode 100644 index 9dc6435c5..000000000 --- a/ext/lapack/dgeqr2.f +++ /dev/null @@ -1,122 +0,0 @@ - SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGEQR2 computes a QR factorization of a real m by n matrix A: -* A = Q * R. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix A. -* On exit, the elements on and above the diagonal of the array -* contain the min(m,n) by n upper trapezoidal matrix R (R is -* upper triangular if m >= n); the elements below the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of elementary reflectors (see Further Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(1) H(2) . . . H(k), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, K - DOUBLE PRECISION AII -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DLARFG, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQR2', -INFO ) - RETURN - END IF -* - K = MIN( M, N ) -* - DO 10 I = 1, K -* -* Generate elementary reflector H(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAU( I ) ) - IF( I.LT.N ) THEN -* -* Apply H(i) to A(i:m,i+1:n) from the left -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - A( I, I ) = AII - END IF - 10 CONTINUE - RETURN -* -* End of DGEQR2 -* - END diff --git a/ext/lapack/dgeqrf.f b/ext/lapack/dgeqrf.f deleted file mode 100644 index 90aeae8ad..000000000 --- a/ext/lapack/dgeqrf.f +++ /dev/null @@ -1,187 +0,0 @@ - SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DGEQRF computes a QR factorization of a real M-by-N matrix A: -* A = Q * R. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix A. -* On exit, the elements on and above the diagonal of the array -* contain the min(M,N)-by-N upper trapezoidal matrix R (R is -* upper triangular if m >= n); the elements below the diagonal, -* with the array TAU, represent the orthogonal matrix Q as a -* product of min(m,n) elementary reflectors (see Further -* Details). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (output) DOUBLE PRECISION array, dimension (min(M,N)) -* The scalar factors of the elementary reflectors (see Further -* Details). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is -* the optimal blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Further Details -* =============== -* -* The matrix Q is represented as a product of elementary reflectors -* -* Q = H(1) H(2) . . . H(k), where k = min(m,n). -* -* Each H(i) has the form -* -* H(i) = I - tau * v * v' -* -* where tau is a real scalar, and v is a real vector with -* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), -* and tau in TAU(i). -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, K, LDWORK, NB, NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGEQRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - K = MIN( M, N ) - IF( K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Determine the block size. -* - NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 ) - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1, - $ -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code initially -* - DO 10 I = 1, K - NX, NB - IB = MIN( K-I+1, NB ) -* -* Compute the QR factorization of the current block -* A(i:m,i:i+ib-1) -* - CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H' to A(i:m,i+ib:n) from the left -* - CALL DLARFB( 'Left', 'Transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF - 10 CONTINUE - ELSE - I = 1 - END IF -* -* Use unblocked code to factor the last or only block. -* - IF( I.LE.K ) - $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* - WORK( 1 ) = IWS - RETURN -* -* End of DGEQRF -* - END diff --git a/ext/lapack/dgerfs.f b/ext/lapack/dgerfs.f deleted file mode 100644 index aa6c13415..000000000 --- a/ext/lapack/dgerfs.f +++ /dev/null @@ -1,332 +0,0 @@ - SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, - $ X, LDX, FERR, BERR, WORK, IWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ), IWORK( * ) - DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ), - $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) -* .. -* -* Purpose -* ======= -* -* DGERFS improves the computed solution to a system of linear -* equations and provides error bounds and backward error estimates for -* the solution. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A**T * X = B (Transpose) -* = 'C': A**H * X = B (Conjugate transpose = Transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrices B and X. NRHS >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The original N-by-N matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* AF (input) DOUBLE PRECISION array, dimension (LDAF,N) -* The factors L and U from the factorization A = P*L*U -* as computed by DGETRF. -* -* LDAF (input) INTEGER -* The leading dimension of the array AF. LDAF >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from DGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS) -* The right hand side matrix B. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS) -* On entry, the solution matrix X, as computed by DGETRS. -* On exit, the improved solution matrix X. -* -* LDX (input) INTEGER -* The leading dimension of the array X. LDX >= max(1,N). -* -* FERR (output) DOUBLE PRECISION array, dimension (NRHS) -* The estimated forward error bound for each solution vector -* X(j) (the j-th column of the solution matrix X). -* If XTRUE is the true solution corresponding to X(j), FERR(j) -* is an estimated upper bound for the magnitude of the largest -* element in (X(j) - XTRUE) divided by the magnitude of the -* largest element in X(j). The estimate is as reliable as -* the estimate for RCOND, and is almost always a slight -* overestimate of the true error. -* -* BERR (output) DOUBLE PRECISION array, dimension (NRHS) -* The componentwise relative backward error of each solution -* vector X(j) (i.e., the smallest relative change in -* any element of A or B that makes X(j) an exact solution). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) -* -* IWORK (workspace) INTEGER array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* Internal Parameters -* =================== -* -* ITMAX is the maximum number of steps of iterative refinement. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER ITMAX - PARAMETER ( ITMAX = 5 ) - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D+0 ) - DOUBLE PRECISION THREE - PARAMETER ( THREE = 3.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN - CHARACTER TRANST - INTEGER COUNT, I, J, K, KASE, NZ - DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DGEMV, DGETRS, DLACON, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -10 - ELSE IF( LDX.LT.MAX( 1, N ) ) THEN - INFO = -12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGERFS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN - DO 10 J = 1, NRHS - FERR( J ) = ZERO - BERR( J ) = ZERO - 10 CONTINUE - RETURN - END IF -* - IF( NOTRAN ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* -* NZ = maximum number of nonzero elements in each row of A, plus 1 -* - NZ = N + 1 - EPS = DLAMCH( 'Epsilon' ) - SAFMIN = DLAMCH( 'Safe minimum' ) - SAFE1 = NZ*SAFMIN - SAFE2 = SAFE1 / EPS -* -* Do for each right hand side -* - DO 140 J = 1, NRHS -* - COUNT = 1 - LSTRES = THREE - 20 CONTINUE -* -* Loop until stopping criterion is satisfied. -* -* Compute residual R = B - op(A) * X, -* where op(A) = A, A**T, or A**H, depending on TRANS. -* - CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 ) - CALL DGEMV( TRANS, N, N, -ONE, A, LDA, X( 1, J ), 1, ONE, - $ WORK( N+1 ), 1 ) -* -* Compute componentwise relative backward error from formula -* -* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) -* -* where abs(Z) is the componentwise absolute value of the matrix -* or vector Z. If the i-th component of the denominator is less -* than SAFE2, then SAFE1 is added to the i-th components of the -* numerator and denominator before dividing. -* - DO 30 I = 1, N - WORK( I ) = ABS( B( I, J ) ) - 30 CONTINUE -* -* Compute abs(op(A))*abs(X) + abs(B). -* - IF( NOTRAN ) THEN - DO 50 K = 1, N - XK = ABS( X( K, J ) ) - DO 40 I = 1, N - WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK - 40 CONTINUE - 50 CONTINUE - ELSE - DO 70 K = 1, N - S = ZERO - DO 60 I = 1, N - S = S + ABS( A( I, K ) )*ABS( X( I, J ) ) - 60 CONTINUE - WORK( K ) = WORK( K ) + S - 70 CONTINUE - END IF - S = ZERO - DO 80 I = 1, N - IF( WORK( I ).GT.SAFE2 ) THEN - S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) ) - ELSE - S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) / - $ ( WORK( I )+SAFE1 ) ) - END IF - 80 CONTINUE - BERR( J ) = S -* -* Test stopping criterion. Continue iterating if -* 1) The residual BERR(J) is larger than machine epsilon, and -* 2) BERR(J) decreased by at least a factor of 2 during the -* last iteration, and -* 3) At most ITMAX iterations tried. -* - IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND. - $ COUNT.LE.ITMAX ) THEN -* -* Update solution and try again. -* - CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N, - $ INFO ) - CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 ) - LSTRES = BERR( J ) - COUNT = COUNT + 1 - GO TO 20 - END IF -* -* Bound error from formula -* -* norm(X - XTRUE) / norm(X) .le. FERR = -* norm( abs(inv(op(A)))* -* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) -* -* where -* norm(Z) is the magnitude of the largest component of Z -* inv(op(A)) is the inverse of op(A) -* abs(Z) is the componentwise absolute value of the matrix or -* vector Z -* NZ is the maximum number of nonzeros in any row of A, plus 1 -* EPS is machine epsilon -* -* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) -* is incremented by SAFE1 if the i-th component of -* abs(op(A))*abs(X) + abs(B) is less than SAFE2. -* -* Use DLACON to estimate the infinity-norm of the matrix -* inv(op(A)) * diag(W), -* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) -* - DO 90 I = 1, N - IF( WORK( I ).GT.SAFE2 ) THEN - WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) - ELSE - WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1 - END IF - 90 CONTINUE -* - KASE = 0 - 100 CONTINUE - CALL DLACON( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ), - $ KASE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.1 ) THEN -* -* Multiply by diag(W)*inv(op(A)**T). -* - CALL DGETRS( TRANST, N, 1, AF, LDAF, IPIV, WORK( N+1 ), - $ N, INFO ) - DO 110 I = 1, N - WORK( N+I ) = WORK( I )*WORK( N+I ) - 110 CONTINUE - ELSE -* -* Multiply by inv(op(A))*diag(W). -* - DO 120 I = 1, N - WORK( N+I ) = WORK( I )*WORK( N+I ) - 120 CONTINUE - CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N, - $ INFO ) - END IF - GO TO 100 - END IF -* -* Normalize error. -* - LSTRES = ZERO - DO 130 I = 1, N - LSTRES = MAX( LSTRES, ABS( X( I, J ) ) ) - 130 CONTINUE - IF( LSTRES.NE.ZERO ) - $ FERR( J ) = FERR( J ) / LSTRES -* - 140 CONTINUE -* - RETURN -* -* End of DGERFS -* - END diff --git a/ext/lapack/dgetf2.f b/ext/lapack/dgetf2.f deleted file mode 100644 index 27610c487..000000000 --- a/ext/lapack/dgetf2.f +++ /dev/null @@ -1,135 +0,0 @@ - SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETF2 computes an LU factorization of a general m-by-n matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, U(k,k) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, JP -* .. -* .. External Functions .. - INTEGER IDAMAX - EXTERNAL IDAMAX -* .. -* .. External Subroutines .. - EXTERNAL DGER, DSCAL, DSWAP, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - DO 10 J = 1, MIN( M, N ) -* -* Find pivot and test for singularity. -* - JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 ) - IPIV( J ) = JP - IF( A( JP, J ).NE.ZERO ) THEN -* -* Apply the interchange to columns 1:N. -* - IF( JP.NE.J ) - $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA ) -* -* Compute elements J+1:M of J-th column. -* - IF( J.LT.M ) - $ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 ) -* - ELSE IF( INFO.EQ.0 ) THEN -* - INFO = J - END IF -* - IF( J.LT.MIN( M, N ) ) THEN -* -* Update trailing submatrix. -* - CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA, - $ A( J+1, J+1 ), LDA ) - END IF - 10 CONTINUE - RETURN -* -* End of DGETF2 -* - END diff --git a/ext/lapack/dgetrf.f b/ext/lapack/dgetrf.f deleted file mode 100644 index 7c7fbf22c..000000000 --- a/ext/lapack/dgetrf.f +++ /dev/null @@ -1,160 +0,0 @@ - SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, M, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DGETRF computes an LU factorization of a general M-by-N matrix A -* using partial pivoting with row interchanges. -* -* The factorization has the form -* A = P * L * U -* where P is a permutation matrix, L is lower triangular with unit -* diagonal elements (lower trapezoidal if m > n), and U is upper -* triangular (upper trapezoidal if m < n). -* -* This is the right-looking Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the M-by-N matrix to be factored. -* On exit, the factors L and U from the factorization -* A = P*L*U; the unit diagonal elements of L are not stored. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* IPIV (output) INTEGER array, dimension (min(M,N)) -* The pivot indices; for 1 <= i <= min(M,N), row i of the -* matrix was interchanged with row IPIV(i). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero. The factorization -* has been completed, but the factor U is exactly -* singular, and division by zero will occur if it is used -* to solve a system of equations. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IINFO, J, JB, NB -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN -* -* Use unblocked code. -* - CALL DGETF2( M, N, A, LDA, IPIV, INFO ) - ELSE -* -* Use blocked code. -* - DO 20 J = 1, MIN( M, N ), NB - JB = MIN( MIN( M, N )-J+1, NB ) -* -* Factor diagonal and subdiagonal blocks and test for exact -* singularity. -* - CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO ) -* -* Adjust INFO and the pivot indices. -* - IF( INFO.EQ.0 .AND. IINFO.GT.0 ) - $ INFO = IINFO + J - 1 - DO 10 I = J, MIN( M, J+JB-1 ) - IPIV( I ) = J - 1 + IPIV( I ) - 10 CONTINUE -* -* Apply interchanges to columns 1:J-1. -* - CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 ) -* - IF( J+JB.LE.N ) THEN -* -* Apply interchanges to columns J+JB:N. -* - CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1, - $ IPIV, 1 ) -* -* Compute block row of U. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB, - $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ), - $ LDA ) - IF( J+JB.LE.M ) THEN -* -* Update trailing submatrix. -* - CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1, - $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA, - $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ), - $ LDA ) - END IF - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DGETRF -* - END diff --git a/ext/lapack/dgetri.f b/ext/lapack/dgetri.f deleted file mode 100644 index efe21b7a0..000000000 --- a/ext/lapack/dgetri.f +++ /dev/null @@ -1,801 +0,0 @@ - SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INFO, LDA, LWORK, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DGETRI computes the inverse of a matrix using the LU factorization -* computed by DGETRF. -* -* This method inverts U and then computes inv(A) by solving the system -* inv(A)*L = inv(U) for inv(A). -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the factors L and U from the factorization -* A = P*L*U as computed by DGETRF. -* On exit, if INFO = 0, the inverse of the original matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from DGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO=0, then WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimal performance LWORK >= N*NB, where NB is -* the optimal blocksize returned by ILAENV. -* -* If LWORK = -1, then a workspace query is assumed; the routine -* only calculates the optimal size of the WORK array, returns -* this value as the first entry of the WORK array, and no error -* message related to LWORK is issued by XERBLA. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is -* singular and its inverse could not be computed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LQUERY - INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB, - $ NBMIN, NN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 ) - LWKOPT = N*NB - WORK( 1 ) = LWKOPT - LQUERY = ( LWORK.EQ.-1 ) - IF( N.LT.0 ) THEN - INFO = -1 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -3 - ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRI', -INFO ) - RETURN - ELSE IF( LQUERY ) THEN - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Form inv(U). If INFO > 0 from DTRTRI, then U is singular, -* and the inverse is not computed. -* - CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO ) - IF( INFO.GT.0 ) - $ RETURN -* - NBMIN = 2 - LDWORK = N - IF( NB.GT.1 .AND. NB.LT.N ) THEN - IWS = MAX( LDWORK*NB, 1 ) - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) ) - END IF - ELSE - IWS = N - END IF -* -* Solve the equation inv(A)*L = inv(U) for inv(A). -* - IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - DO 20 J = N, 1, -1 -* -* Copy current column of L to WORK and replace with zeros. -* - DO 10 I = J + 1, N - WORK( I ) = A( I, J ) - A( I, J ) = ZERO - 10 CONTINUE -* -* Compute current column of inv(A). -* - IF( J.LT.N ) - $ CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ), - $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 ) - 20 CONTINUE - ELSE -* -* Use blocked code. -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 50 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) -* -* Copy current block column of L to WORK and replace with -* zeros. -* - DO 40 JJ = J, J + JB - 1 - DO 30 I = JJ + 1, N - WORK( I+( JJ-J )*LDWORK ) = A( I, JJ ) - A( I, JJ ) = ZERO - 30 CONTINUE - 40 CONTINUE -* -* Compute current block column of inv(A). -* - IF( J+JB.LE.N ) - $ CALL DGEMM( 'No transpose', 'No transpose', N, JB, - $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA, - $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB, - $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA ) - 50 CONTINUE - END IF -* -* Apply column interchanges. -* - DO 60 J = N - 1, 1, -1 - JP = IPIV( J ) - IF( JP.NE.J ) - $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 ) - 60 CONTINUE -* - WORK( 1 ) = IWS - RETURN -* -* End of DGETRI -* - END - SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DTRTI2 computes the inverse of a real upper or lower triangular -* matrix. -* -* This is the Level 2 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the matrix A is upper or lower triangular. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* DIAG (input) CHARACTER*1 -* Specifies whether or not the matrix A is unit triangular. -* = 'N': Non-unit triangular -* = 'U': Unit triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading n by n upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DSCAL, DTRMV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTI2', -INFO ) - RETURN - END IF -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix. -* - DO 10 J = 1, N - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF -* -* Compute elements 1:j-1 of j-th column. -* - CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA, - $ A( 1, J ), 1 ) - CALL DSCAL( J-1, AJJ, A( 1, J ), 1 ) - 10 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix. -* - DO 20 J = N, 1, -1 - IF( NOUNIT ) THEN - A( J, J ) = ONE / A( J, J ) - AJJ = -A( J, J ) - ELSE - AJJ = -ONE - END IF - IF( J.LT.N ) THEN -* -* Compute elements j+1:n of j-th column. -* - CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J, - $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 ) - CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF -* - RETURN -* -* End of DTRTI2 -* - END - SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER DIAG, UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DTRTRI computes the inverse of a real upper or lower triangular -* matrix A. -* -* This is the Level 3 BLAS version of the algorithm. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': A is upper triangular; -* = 'L': A is lower triangular. -* -* DIAG (input) CHARACTER*1 -* = 'N': A is non-unit triangular; -* = 'U': A is unit triangular. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the triangular matrix A. If UPLO = 'U', the -* leading N-by-N upper triangular part of the array A contains -* the upper triangular matrix, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of the array A contains -* the lower triangular matrix, and the strictly upper -* triangular part of A is not referenced. If DIAG = 'U', the -* diagonal elements of A are also not referenced and are -* assumed to be 1. -* On exit, the (triangular) inverse of the original matrix, in -* the same storage format. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, A(i,i) is exactly zero. The triangular -* matrix is singular and its inverse can not be computed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, UPPER - INTEGER J, JB, NB, NN -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -2 - ELSE IF( N.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTRI', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check for singularity if non-unit. -* - IF( NOUNIT ) THEN - DO 10 INFO = 1, N - IF( A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - INFO = 0 - END IF -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code -* - CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) - ELSE -* -* Use blocked code -* - IF( UPPER ) THEN -* -* Compute inverse of upper triangular matrix -* - DO 20 J = 1, N, NB - JB = MIN( NB, N-J+1 ) -* -* Compute rows 1:j-1 of current block column -* - CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1, - $ JB, ONE, A, LDA, A( 1, J ), LDA ) - CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1, - $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA ) -* -* Compute inverse of current diagonal block -* - CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO ) - 20 CONTINUE - ELSE -* -* Compute inverse of lower triangular matrix -* - NN = ( ( N-1 ) / NB )*NB + 1 - DO 30 J = NN, 1, -NB - JB = MIN( NB, N-J+1 ) - IF( J+JB.LE.N ) THEN -* -* Compute rows j+jb:n of current block column -* - CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA, - $ A( J+JB, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG, - $ N-J-JB+1, JB, -ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF -* -* Compute inverse of current diagonal block -* - CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO ) - 30 CONTINUE - END IF - END IF -* - RETURN -* -* End of DTRTRI -* - END - INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1998 -* -* .. Scalar Arguments .. - INTEGER ISPEC - REAL ONE, ZERO -* .. -* -* Purpose -* ======= -* -* IEEECK is called from the ILAENV to verify that Infinity and -* possibly NaN arithmetic is safe (i.e. will not trap). -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies whether to test just for inifinity arithmetic -* or whether to test for infinity and NaN arithmetic. -* = 0: Verify infinity arithmetic only. -* = 1: Verify infinity and NaN arithmetic. -* -* ZERO (input) REAL -* Must contain the value 0.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* ONE (input) REAL -* Must contain the value 1.0 -* This is passed to prevent the compiler from optimizing -* away this code. -* -* RETURN VALUE: INTEGER -* = 0: Arithmetic failed to produce the correct answers -* = 1: Arithmetic produced the correct answers -* -* .. Local Scalars .. - REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF, - $ NEGZRO, NEWZRO, POSINF -* .. -* .. Executable Statements .. - IEEECK = 1 -* - POSINF = ONE / ZERO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = -ONE / ZERO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGZRO = ONE / ( NEGINF+ONE ) - IF( NEGZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = ONE / NEGZRO - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - NEWZRO = NEGZRO + ZERO - IF( NEWZRO.NE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = ONE / NEWZRO - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* - NEGINF = NEGINF*POSINF - IF( NEGINF.GE.ZERO ) THEN - IEEECK = 0 - RETURN - END IF -* - POSINF = POSINF*POSINF - IF( POSINF.LE.ONE ) THEN - IEEECK = 0 - RETURN - END IF -* -* -* -* -* Return if we were only asked to check infinity arithmetic -* - IF( ISPEC.EQ.0 ) - $ RETURN -* - NAN1 = POSINF + NEGINF -* - NAN2 = POSINF / NEGINF -* - NAN3 = POSINF / POSINF -* - NAN4 = POSINF*ZERO -* - NAN5 = NEGINF*NEGZRO -* - NAN6 = NAN5*0.0 -* - IF( NAN1.EQ.NAN1 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN2.EQ.NAN2 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN3.EQ.NAN3 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN4.EQ.NAN4 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN5.EQ.NAN5 ) THEN - IEEECK = 0 - RETURN - END IF -* - IF( NAN6.EQ.NAN6 ) THEN - IEEECK = 0 - RETURN - END IF -* - RETURN - END - -c END - -c LOGICAL FUNCTION LSAME( CA, CB ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. -c CHARACTER CA, CB -* .. -* -* Purpose -* ======= -* -* LSAME returns .TRUE. if CA is the same letter as CB regardless of -* case. -* -* Arguments -* ========= -* -* CA (input) CHARACTER*1 -* CB (input) CHARACTER*1 -* CA and CB specify the single characters to be compared. -* -* ===================================================================== -* -* .. Intrinsic Functions .. -c INTRINSIC ICHAR -* .. -* .. Local Scalars .. -c INTEGER INTA, INTB, ZCODE -* .. -* .. Executable Statements .. -* -* Test if the characters are equal -* -c LSAME = CA.EQ.CB -c IF( LSAME ) -c $ RETURN -* -* Now test for equivalence if both characters are alphabetic. -* -c ZCODE = ICHAR( 'Z' ) -* -* Use 'Z' rather than 'A' so that ASCII can be detected on Prime -* machines, on which ICHAR returns a value with bit 8 set. -* ICHAR('A') on Prime machines returns 193 which is the same as -* ICHAR('A') on an EBCDIC machine. -* -c INTA = ICHAR( CA ) -c INTB = ICHAR( CB ) -* -c IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN -* -* ASCII is assumed - ZCODE is the ASCII code of either lower or -* upper case 'Z'. -* -c IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 -c IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 -* -c ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN -* -* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or -* upper case 'Z'. -* -c IF( INTA.GE.129 .AND. INTA.LE.137 .OR. -c $ INTA.GE.145 .AND. INTA.LE.153 .OR. -c $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 -c IF( INTB.GE.129 .AND. INTB.LE.137 .OR. -c $ INTB.GE.145 .AND. INTB.LE.153 .OR. -c $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 -* -c ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN -* -* ASCII is assumed, on Prime machines - ZCODE is the ASCII code -* plus 128 of either lower or upper case 'Z'. -* -c IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 -c IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 -c END IF -c LSAME = INTA.EQ.INTB -* -* RETURN -* -* End of LSAME -* -c END -c$$$ SUBROUTINE XERBLA( SRNAME, INFO ) -c$$$* -c$$$* -- LAPACK auxiliary routine (version 3.0) -- -c$$$* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -c$$$* Courant Institute, Argonne National Lab, and Rice University -c$$$* September 30, 1994 -c$$$* -c$$$* .. Scalar Arguments .. -c$$$ CHARACTER*6 SRNAME -c$$$ INTEGER INFO -c$$$* .. -c$$$* -c$$$* Purpose -c$$$* ======= -c$$$* -c$$$* XERBLA is an error handler for the LAPACK routines. -c$$$* It is called by an LAPACK routine if an input parameter has an -c$$$* invalid value. A message is printed and execution stops. -c$$$* -c$$$* Installers may consider modifying the STOP statement in order to -c$$$* call system-specific exception-handling facilities. -c$$$* -c$$$* Arguments -c$$$* ========= -c$$$* -c$$$* SRNAME (input) CHARACTER*6 -c$$$* The name of the routine which called XERBLA. -c$$$* -c$$$* INFO (input) INTEGER -c$$$* The position of the invalid parameter in the parameter list -c$$$* of the calling routine. -c$$$* -c$$$* ===================================================================== -c$$$* -c$$$* .. Executable Statements .. -c$$$* -c$$$ WRITE( *, FMT = 9999 )SRNAME, INFO -c$$$* -c$$$ STOP -c$$$* -c$$$ 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', -c$$$ $ 'an illegal value' ) -c$$$* -c$$$* End of XERBLA -c$$$* -c$$$ END \ No newline at end of file diff --git a/ext/lapack/dgetrs.f b/ext/lapack/dgetrs.f deleted file mode 100644 index 1d0db1e91..000000000 --- a/ext/lapack/dgetrs.f +++ /dev/null @@ -1,150 +0,0 @@ - SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER TRANS - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DGETRS solves a system of linear equations -* A * X = B or A' * X = B -* with a general N-by-N matrix A using the LU factorization computed -* by DGETRF. -* -* Arguments -* ========= -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A'* X = B (Transpose) -* = 'C': A'* X = B (Conjugate transpose = Transpose) -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The factors L and U from the factorization A = P*L*U -* as computed by DGETRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* IPIV (input) INTEGER array, dimension (N) -* The pivot indices from DGETRF; for 1<=i<=N, row i of the -* matrix was interchanged with row IPIV(i). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLASWP, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOTRAN = LSAME( TRANS, 'N' ) - IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DGETRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( NOTRAN ) THEN -* -* Solve A * X = B. -* -* Apply row interchanges to the right hand sides. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 ) -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A' * X = B. -* -* Solve U'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve L'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE, - $ A, LDA, B, LDB ) -* -* Apply row interchanges to the solution vectors. -* - CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 ) - END IF -* - RETURN -* -* End of DGETRS -* - END diff --git a/ext/lapack/dlabad.f b/ext/lapack/dlabad.f deleted file mode 100644 index 1f453d222..000000000 --- a/ext/lapack/dlabad.f +++ /dev/null @@ -1,56 +0,0 @@ - SUBROUTINE DLABAD( SMALL, LARGE ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - DOUBLE PRECISION LARGE, SMALL -* .. -* -* Purpose -* ======= -* -* DLABAD takes as input the values computed by SLAMCH for underflow and -* overflow, and returns the square root of each of these values if the -* log of LARGE is sufficiently large. This subroutine is intended to -* identify machines with a large exponent range, such as the Crays, and -* redefine the underflow and overflow limits to be the square roots of -* the values computed by DLAMCH. This subroutine is needed because -* DLAMCH does not compensate for poor arithmetic in the upper half of -* the exponent range, as is found on a Cray. -* -* Arguments -* ========= -* -* SMALL (input/output) DOUBLE PRECISION -* On entry, the underflow threshold as computed by DLAMCH. -* On exit, if LOG10(LARGE) is sufficiently large, the square -* root of SMALL, otherwise unchanged. -* -* LARGE (input/output) DOUBLE PRECISION -* On entry, the overflow threshold as computed by DLAMCH. -* On exit, if LOG10(LARGE) is sufficiently large, the square -* root of LARGE, otherwise unchanged. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC LOG10, SQRT -* .. -* .. Executable Statements .. -* -* If it looks like we're on a Cray, take the square root of -* SMALL and LARGE to avoid overflow and underflow problems. -* - IF( LOG10( LARGE ).GT.2000.D0 ) THEN - SMALL = SQRT( SMALL ) - LARGE = SQRT( LARGE ) - END IF -* - RETURN -* -* End of DLABAD -* - END diff --git a/ext/lapack/dlabrd.f b/ext/lapack/dlabrd.f deleted file mode 100644 index 50d333af4..000000000 --- a/ext/lapack/dlabrd.f +++ /dev/null @@ -1,291 +0,0 @@ - SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, - $ LDY ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER LDA, LDX, LDY, M, N, NB -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ), - $ TAUQ( * ), X( LDX, * ), Y( LDY, * ) -* .. -* -* Purpose -* ======= -* -* DLABRD reduces the first NB rows and columns of a real general -* m by n matrix A to upper or lower bidiagonal form by an orthogonal -* transformation Q' * A * P, and returns the matrices X and Y which -* are needed to apply the transformation to the unreduced part of A. -* -* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower -* bidiagonal form. -* -* This is an auxiliary routine called by DGEBRD -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows in the matrix A. -* -* N (input) INTEGER -* The number of columns in the matrix A. -* -* NB (input) INTEGER -* The number of leading rows and columns of A to be reduced. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the m by n general matrix to be reduced. -* On exit, the first NB rows and columns of the matrix are -* overwritten; the rest of the array is unchanged. -* If m >= n, elements on and below the diagonal in the first NB -* columns, with the array TAUQ, represent the orthogonal -* matrix Q as a product of elementary reflectors; and -* elements above the diagonal in the first NB rows, with the -* array TAUP, represent the orthogonal matrix P as a product -* of elementary reflectors. -* If m < n, elements below the diagonal in the first NB -* columns, with the array TAUQ, represent the orthogonal -* matrix Q as a product of elementary reflectors, and -* elements on and above the diagonal in the first NB rows, -* with the array TAUP, represent the orthogonal matrix P as -* a product of elementary reflectors. -* See Further Details. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* D (output) DOUBLE PRECISION array, dimension (NB) -* The diagonal elements of the first NB rows and columns of -* the reduced matrix. D(i) = A(i,i). -* -* E (output) DOUBLE PRECISION array, dimension (NB) -* The off-diagonal elements of the first NB rows and columns of -* the reduced matrix. -* -* TAUQ (output) DOUBLE PRECISION array dimension (NB) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix Q. See Further Details. -* -* TAUP (output) DOUBLE PRECISION array, dimension (NB) -* The scalar factors of the elementary reflectors which -* represent the orthogonal matrix P. See Further Details. -* -* X (output) DOUBLE PRECISION array, dimension (LDX,NB) -* The m-by-nb matrix X required to update the unreduced part -* of A. -* -* LDX (input) INTEGER -* The leading dimension of the array X. LDX >= M. -* -* Y (output) DOUBLE PRECISION array, dimension (LDY,NB) -* The n-by-nb matrix Y required to update the unreduced part -* of A. -* -* LDY (output) INTEGER -* The leading dimension of the array Y. LDY >= N. -* -* Further Details -* =============== -* -* The matrices Q and P are represented as products of elementary -* reflectors: -* -* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) -* -* Each H(i) and G(i) has the form: -* -* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u' -* -* where tauq and taup are real scalars, and v and u are real vectors. -* -* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in -* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in -* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in -* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in -* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). -* -* The elements of the vectors v and u together form the m-by-nb matrix -* V and the nb-by-n matrix U' which are needed, with X and Y, to apply -* the transformation to the unreduced part of the matrix, using a block -* update of the form: A := A - V*Y' - X*U'. -* -* The contents of A on exit are illustrated by the following examples -* with nb = 2: -* -* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): -* -* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) -* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) -* ( v1 v2 a a a ) ( v1 1 a a a a ) -* ( v1 v2 a a a ) ( v1 v2 a a a a ) -* ( v1 v2 a a a ) ( v1 v2 a a a a ) -* ( v1 v2 a a a ) -* -* where a denotes an element of the original matrix which is unchanged, -* vi denotes an element of the vector defining H(i), and ui an element -* of the vector defining G(i). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER I -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DLARFG, DSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( M.GE.N ) THEN -* -* Reduce to upper bidiagonal form -* - DO 10 I = 1, NB -* -* Update A(i:m,i) -* - CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ), - $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 ) - CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ), - $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 ) -* -* Generate reflection Q(i) to annihilate A(i+1:m,i) -* - CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1, - $ TAUQ( I ) ) - D( I ) = A( I, I ) - IF( I.LT.N ) THEN - A( I, I ) = ONE -* -* Compute Y(i+1:n,i) -* - CALL DGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ), - $ LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA, - $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), - $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX, - $ A( I, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), - $ LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) -* -* Update A(i,i+1:n) -* - CALL DGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ), - $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA ) - CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ), - $ LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA ) -* -* Generate reflection P(i) to annihilate A(i,i+2:n) -* - CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ), - $ LDA, TAUP( I ) ) - E( I ) = A( I, I+1 ) - A( I, I+1 ) = ONE -* -* Compute X(i+1:m,i) -* - CALL DGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ), - $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY, - $ A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ), - $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ), - $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), - $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) - END IF - 10 CONTINUE - ELSE -* -* Reduce to lower bidiagonal form -* - DO 20 I = 1, NB -* -* Update A(i,i:n) -* - CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ), - $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA ) - CALL DGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA, - $ X( I, 1 ), LDX, ONE, A( I, I ), LDA ) -* -* Generate reflection P(i) to annihilate A(i,i+1:n) -* - CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA, - $ TAUP( I ) ) - D( I ) = A( I, I ) - IF( I.LT.M ) THEN - A( I, I ) = ONE -* -* Compute X(i+1:m,i) -* - CALL DGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ), - $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY, - $ A( I, I ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ), - $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ), - $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 ) - CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 ) -* -* Update A(i+1:m,i) -* - CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ), - $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 ) - CALL DGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ), - $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 ) -* -* Generate reflection Q(i) to annihilate A(i+2:m,i) -* - CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1, - $ TAUQ( I ) ) - E( I ) = A( I+1, I ) - A( I+1, I ) = ONE -* -* Compute Y(i+1:n,i) -* - CALL DGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ), - $ LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA, - $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ), - $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX, - $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 ) - CALL DGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA, - $ Y( 1, I ), 1, ONE, Y( I+1, I ), 1 ) - CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 ) - END IF - 20 CONTINUE - END IF - RETURN -* -* End of DLABRD -* - END diff --git a/ext/lapack/dlacon.f b/ext/lapack/dlacon.f deleted file mode 100644 index 4efa0e816..000000000 --- a/ext/lapack/dlacon.f +++ /dev/null @@ -1,204 +0,0 @@ - SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER KASE, N - DOUBLE PRECISION EST -* .. -* .. Array Arguments .. - INTEGER ISGN( * ) - DOUBLE PRECISION V( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DLACON estimates the 1-norm of a square, real matrix A. -* Reverse communication is used for evaluating matrix-vector products. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the matrix. N >= 1. -* -* V (workspace) DOUBLE PRECISION array, dimension (N) -* On the final return, V = A*W, where EST = norm(V)/norm(W) -* (W is not returned). -* -* X (input/output) DOUBLE PRECISION array, dimension (N) -* On an intermediate return, X should be overwritten by -* A * X, if KASE=1, -* A' * X, if KASE=2, -* and DLACON must be re-called with all the other parameters -* unchanged. -* -* ISGN (workspace) INTEGER array, dimension (N) -* -* EST (output) DOUBLE PRECISION -* An estimate (a lower bound) for norm(A). -* -* KASE (input/output) INTEGER -* On the initial call to DLACON, KASE should be 0. -* On an intermediate return, KASE will be 1 or 2, indicating -* whether X should be overwritten by A * X or A' * X. -* On the final return from DLACON, KASE will again be 0. -* -* Further Details -* ======= ======= -* -* Contributed by Nick Higham, University of Manchester. -* Originally named SONEST, dated March 16, 1988. -* -* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of -* a real or complex matrix, with applications to condition estimation", -* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. -* -* ===================================================================== -* -* .. Parameters .. - INTEGER ITMAX - PARAMETER ( ITMAX = 5 ) - DOUBLE PRECISION ZERO, ONE, TWO - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, ITER, J, JLAST, JUMP - DOUBLE PRECISION ALTSGN, ESTOLD, TEMP -* .. -* .. External Functions .. - INTEGER IDAMAX - DOUBLE PRECISION DASUM - EXTERNAL IDAMAX, DASUM -* .. -* .. External Subroutines .. - EXTERNAL DCOPY -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, NINT, SIGN -* .. -* .. Save statement .. - SAVE -* .. -* .. Executable Statements .. -* - IF( KASE.EQ.0 ) THEN - DO 10 I = 1, N - X( I ) = ONE / DBLE( N ) - 10 CONTINUE - KASE = 1 - JUMP = 1 - RETURN - END IF -* - GO TO ( 20, 40, 70, 110, 140 )JUMP -* -* ................ ENTRY (JUMP = 1) -* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. -* - 20 CONTINUE - IF( N.EQ.1 ) THEN - V( 1 ) = X( 1 ) - EST = ABS( V( 1 ) ) -* ... QUIT - GO TO 150 - END IF - EST = DASUM( N, X, 1 ) -* - DO 30 I = 1, N - X( I ) = SIGN( ONE, X( I ) ) - ISGN( I ) = NINT( X( I ) ) - 30 CONTINUE - KASE = 2 - JUMP = 2 - RETURN -* -* ................ ENTRY (JUMP = 2) -* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. -* - 40 CONTINUE - J = IDAMAX( N, X, 1 ) - ITER = 2 -* -* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. -* - 50 CONTINUE - DO 60 I = 1, N - X( I ) = ZERO - 60 CONTINUE - X( J ) = ONE - KASE = 1 - JUMP = 3 - RETURN -* -* ................ ENTRY (JUMP = 3) -* X HAS BEEN OVERWRITTEN BY A*X. -* - 70 CONTINUE - CALL DCOPY( N, X, 1, V, 1 ) - ESTOLD = EST - EST = DASUM( N, V, 1 ) - DO 80 I = 1, N - IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) ) - $ GO TO 90 - 80 CONTINUE -* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED. - GO TO 120 -* - 90 CONTINUE -* TEST FOR CYCLING. - IF( EST.LE.ESTOLD ) - $ GO TO 120 -* - DO 100 I = 1, N - X( I ) = SIGN( ONE, X( I ) ) - ISGN( I ) = NINT( X( I ) ) - 100 CONTINUE - KASE = 2 - JUMP = 4 - RETURN -* -* ................ ENTRY (JUMP = 4) -* X HAS BEEN OVERWRITTEN BY TRANDPOSE(A)*X. -* - 110 CONTINUE - JLAST = J - J = IDAMAX( N, X, 1 ) - IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN - ITER = ITER + 1 - GO TO 50 - END IF -* -* ITERATION COMPLETE. FINAL STAGE. -* - 120 CONTINUE - ALTSGN = ONE - DO 130 I = 1, N - X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) ) - ALTSGN = -ALTSGN - 130 CONTINUE - KASE = 1 - JUMP = 5 - RETURN -* -* ................ ENTRY (JUMP = 5) -* X HAS BEEN OVERWRITTEN BY A*X. -* - 140 CONTINUE - TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) ) - IF( TEMP.GT.EST ) THEN - CALL DCOPY( N, X, 1, V, 1 ) - EST = TEMP - END IF -* - 150 CONTINUE - KASE = 0 - RETURN -* -* End of DLACON -* - END diff --git a/ext/lapack/dlacpy.f b/ext/lapack/dlacpy.f deleted file mode 100644 index 6820d45fb..000000000 --- a/ext/lapack/dlacpy.f +++ /dev/null @@ -1,88 +0,0 @@ - SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, LDB, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DLACPY copies all or part of a two-dimensional matrix A to another -* matrix B. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies the part of the matrix A to be copied to B. -* = 'U': Upper triangular part -* = 'L': Lower triangular part -* Otherwise: All of the matrix A -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The m by n matrix A. If UPLO = 'U', only the upper triangle -* or trapezoid is accessed; if UPLO = 'L', only the lower -* triangle or trapezoid is accessed. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* B (output) DOUBLE PRECISION array, dimension (LDB,N) -* On exit, B = A in the locations specified by UPLO. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,M). -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, MIN( J, M ) - B( I, J ) = A( I, J ) - 10 CONTINUE - 20 CONTINUE - ELSE IF( LSAME( UPLO, 'L' ) ) THEN - DO 40 J = 1, N - DO 30 I = J, M - B( I, J ) = A( I, J ) - 30 CONTINUE - 40 CONTINUE - ELSE - DO 60 J = 1, N - DO 50 I = 1, M - B( I, J ) = A( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF - RETURN -* -* End of DLACPY -* - END diff --git a/ext/lapack/dlamch.f b/ext/lapack/dlamch.f deleted file mode 100644 index e293aa8c7..000000000 --- a/ext/lapack/dlamch.f +++ /dev/null @@ -1,857 +0,0 @@ - DOUBLE PRECISION FUNCTION DLAMCH( CMACH ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER CMACH -* .. -* -* Purpose -* ======= -* -* DLAMCH determines double precision machine parameters. -* -* Arguments -* ========= -* -* CMACH (input) CHARACTER*1 -* Specifies the value to be returned by DLAMCH: -* = 'E' or 'e', DLAMCH := eps -* = 'S' or 's , DLAMCH := sfmin -* = 'B' or 'b', DLAMCH := base -* = 'P' or 'p', DLAMCH := eps*base -* = 'N' or 'n', DLAMCH := t -* = 'R' or 'r', DLAMCH := rnd -* = 'M' or 'm', DLAMCH := emin -* = 'U' or 'u', DLAMCH := rmin -* = 'L' or 'l', DLAMCH := emax -* = 'O' or 'o', DLAMCH := rmax -* -* where -* -* eps = relative machine precision -* sfmin = safe minimum, such that 1/sfmin does not overflow -* base = base of the machine -* prec = eps*base -* t = number of (base) digits in the mantissa -* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise -* emin = minimum exponent before (gradual) underflow -* rmin = underflow threshold - base**(emin-1) -* emax = largest exponent before overflow -* rmax = overflow threshold - (base**emax)*(1-eps) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL FIRST, LRND - INTEGER BETA, IMAX, IMIN, IT - DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN, - $ RND, SFMIN, SMALL, T -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLAMC2 -* .. -* .. Save statement .. - SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN, - $ EMAX, RMAX, PREC -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX ) - BASE = BETA - T = IT - IF( LRND ) THEN - RND = ONE - EPS = ( BASE**( 1-IT ) ) / 2 - ELSE - RND = ZERO - EPS = BASE**( 1-IT ) - END IF - PREC = EPS*BASE - EMIN = IMIN - EMAX = IMAX - SFMIN = RMIN - SMALL = ONE / RMAX - IF( SMALL.GE.SFMIN ) THEN -* -* Use SMALL plus a bit, to avoid the possibility of rounding -* causing overflow when computing 1/sfmin. -* - SFMIN = SMALL*( ONE+EPS ) - END IF - END IF -* - IF( LSAME( CMACH, 'E' ) ) THEN - RMACH = EPS - ELSE IF( LSAME( CMACH, 'S' ) ) THEN - RMACH = SFMIN - ELSE IF( LSAME( CMACH, 'B' ) ) THEN - RMACH = BASE - ELSE IF( LSAME( CMACH, 'P' ) ) THEN - RMACH = PREC - ELSE IF( LSAME( CMACH, 'N' ) ) THEN - RMACH = T - ELSE IF( LSAME( CMACH, 'R' ) ) THEN - RMACH = RND - ELSE IF( LSAME( CMACH, 'M' ) ) THEN - RMACH = EMIN - ELSE IF( LSAME( CMACH, 'U' ) ) THEN - RMACH = RMIN - ELSE IF( LSAME( CMACH, 'L' ) ) THEN - RMACH = EMAX - ELSE IF( LSAME( CMACH, 'O' ) ) THEN - RMACH = RMAX - END IF -* - DLAMCH = RMACH - RETURN -* -* End of DLAMCH -* - END -* -************************************************************************ -* - SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - LOGICAL IEEE1, RND - INTEGER BETA, T -* .. -* -* Purpose -* ======= -* -* DLAMC1 determines the machine parameters given by BETA, T, RND, and -* IEEE1. -* -* Arguments -* ========= -* -* BETA (output) INTEGER -* The base of the machine. -* -* T (output) INTEGER -* The number of ( BETA ) digits in the mantissa. -* -* RND (output) LOGICAL -* Specifies whether proper rounding ( RND = .TRUE. ) or -* chopping ( RND = .FALSE. ) occurs in addition. This may not -* be a reliable guide to the way in which the machine performs -* its arithmetic. -* -* IEEE1 (output) LOGICAL -* Specifies whether rounding appears to be done in the IEEE -* 'round to nearest' style. -* -* Further Details -* =============== -* -* The routine is based on the routine ENVRON by Malcolm and -* incorporates suggestions by Gentleman and Marovich. See -* -* Malcolm M. A. (1972) Algorithms to reveal properties of -* floating-point arithmetic. Comms. of the ACM, 15, 949-951. -* -* Gentleman W. M. and Marovich S. B. (1974) More on algorithms -* that reveal properties of floating point arithmetic units. -* Comms. of the ACM, 17, 276-277. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL FIRST, LIEEE1, LRND - INTEGER LBETA, LT - DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2 -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3 - EXTERNAL DLAMC3 -* .. -* .. Save statement .. - SAVE FIRST, LIEEE1, LBETA, LRND, LT -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - ONE = 1 -* -* LBETA, LIEEE1, LT and LRND are the local values of BETA, -* IEEE1, T and RND. -* -* Throughout this routine we use the function DLAMC3 to ensure -* that relevant values are stored and not held in registers, or -* are not affected by optimizers. -* -* Compute a = 2.0**m with the smallest positive integer m such -* that -* -* fl( a + 1.0 ) = a. -* - A = 1 - C = 1 -* -*+ WHILE( C.EQ.ONE )LOOP - 10 CONTINUE - IF( C.EQ.ONE ) THEN - A = 2*A - C = DLAMC3( A, ONE ) - C = DLAMC3( C, -A ) - GO TO 10 - END IF -*+ END WHILE -* -* Now compute b = 2.0**m with the smallest positive integer m -* such that -* -* fl( a + b ) .gt. a. -* - B = 1 - C = DLAMC3( A, B ) -* -*+ WHILE( C.EQ.A )LOOP - 20 CONTINUE - IF( C.EQ.A ) THEN - B = 2*B - C = DLAMC3( A, B ) - GO TO 20 - END IF -*+ END WHILE -* -* Now compute the base. a and c are neighbouring floating point -* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so -* their difference is beta. Adding 0.25 to c is to ensure that it -* is truncated to beta and not ( beta - 1 ). -* - QTR = ONE / 4 - SAVEC = C - C = DLAMC3( C, -A ) - LBETA = C + QTR -* -* Now determine whether rounding or chopping occurs, by adding a -* bit less than beta/2 and a bit more than beta/2 to a. -* - B = LBETA - F = DLAMC3( B / 2, -B / 100 ) - C = DLAMC3( F, A ) - IF( C.EQ.A ) THEN - LRND = .TRUE. - ELSE - LRND = .FALSE. - END IF - F = DLAMC3( B / 2, B / 100 ) - C = DLAMC3( F, A ) - IF( ( LRND ) .AND. ( C.EQ.A ) ) - $ LRND = .FALSE. -* -* Try and decide whether rounding is done in the IEEE 'round to -* nearest' style. B/2 is half a unit in the last place of the two -* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit -* zero, and SAVEC is odd. Thus adding B/2 to A should not change -* A, but adding B/2 to SAVEC should change SAVEC. -* - T1 = DLAMC3( B / 2, A ) - T2 = DLAMC3( B / 2, SAVEC ) - LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND -* -* Now find the mantissa, t. It should be the integer part of -* log to the base beta of a, however it is safer to determine t -* by powering. So we find t as the smallest positive integer for -* which -* -* fl( beta**t + 1.0 ) = 1.0. -* - LT = 0 - A = 1 - C = 1 -* -*+ WHILE( C.EQ.ONE )LOOP - 30 CONTINUE - IF( C.EQ.ONE ) THEN - LT = LT + 1 - A = A*LBETA - C = DLAMC3( A, ONE ) - C = DLAMC3( C, -A ) - GO TO 30 - END IF -*+ END WHILE -* - END IF -* - BETA = LBETA - T = LT - RND = LRND - IEEE1 = LIEEE1 - RETURN -* -* End of DLAMC1 -* - END -* -************************************************************************ -* - SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - LOGICAL RND - INTEGER BETA, EMAX, EMIN, T - DOUBLE PRECISION EPS, RMAX, RMIN -* .. -* -* Purpose -* ======= -* -* DLAMC2 determines the machine parameters specified in its argument -* list. -* -* Arguments -* ========= -* -* BETA (output) INTEGER -* The base of the machine. -* -* T (output) INTEGER -* The number of ( BETA ) digits in the mantissa. -* -* RND (output) LOGICAL -* Specifies whether proper rounding ( RND = .TRUE. ) or -* chopping ( RND = .FALSE. ) occurs in addition. This may not -* be a reliable guide to the way in which the machine performs -* its arithmetic. -* -* EPS (output) DOUBLE PRECISION -* The smallest positive number such that -* -* fl( 1.0 - EPS ) .LT. 1.0, -* -* where fl denotes the computed value. -* -* EMIN (output) INTEGER -* The minimum exponent before (gradual) underflow occurs. -* -* RMIN (output) DOUBLE PRECISION -* The smallest normalized number for the machine, given by -* BASE**( EMIN - 1 ), where BASE is the floating point value -* of BETA. -* -* EMAX (output) INTEGER -* The maximum exponent before overflow occurs. -* -* RMAX (output) DOUBLE PRECISION -* The largest positive number for the machine, given by -* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point -* value of BETA. -* -* Further Details -* =============== -* -* The computation of EPS is based on a routine PARANOIA by -* W. Kahan of the University of California at Berkeley. -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND - INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT, - $ NGNMIN, NGPMIN - DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE, - $ SIXTH, SMALL, THIRD, TWO, ZERO -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3 - EXTERNAL DLAMC3 -* .. -* .. External Subroutines .. - EXTERNAL DLAMC1, DLAMC4, DLAMC5 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Save statement .. - SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX, - $ LRMIN, LT -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / , IWARN / .FALSE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - ZERO = 0 - ONE = 1 - TWO = 2 -* -* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of -* BETA, T, RND, EPS, EMIN and RMIN. -* -* Throughout this routine we use the function DLAMC3 to ensure -* that relevant values are stored and not held in registers, or -* are not affected by optimizers. -* -* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. -* - CALL DLAMC1( LBETA, LT, LRND, LIEEE1 ) -* -* Start to find EPS. -* - B = LBETA - A = B**( -LT ) - LEPS = A -* -* Try some tricks to see whether or not this is the correct EPS. -* - B = TWO / 3 - HALF = ONE / 2 - SIXTH = DLAMC3( B, -HALF ) - THIRD = DLAMC3( SIXTH, SIXTH ) - B = DLAMC3( THIRD, -HALF ) - B = DLAMC3( B, SIXTH ) - B = ABS( B ) - IF( B.LT.LEPS ) - $ B = LEPS -* - LEPS = 1 -* -*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP - 10 CONTINUE - IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN - LEPS = B - C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) - C = DLAMC3( HALF, -C ) - B = DLAMC3( HALF, C ) - C = DLAMC3( HALF, -B ) - B = DLAMC3( HALF, C ) - GO TO 10 - END IF -*+ END WHILE -* - IF( A.LT.LEPS ) - $ LEPS = A -* -* Computation of EPS complete. -* -* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). -* Keep dividing A by BETA until (gradual) underflow occurs. This -* is detected when we cannot recover the previous A. -* - RBASE = ONE / LBETA - SMALL = ONE - DO 20 I = 1, 3 - SMALL = DLAMC3( SMALL*RBASE, ZERO ) - 20 CONTINUE - A = DLAMC3( ONE, SMALL ) - CALL DLAMC4( NGPMIN, ONE, LBETA ) - CALL DLAMC4( NGNMIN, -ONE, LBETA ) - CALL DLAMC4( GPMIN, A, LBETA ) - CALL DLAMC4( GNMIN, -A, LBETA ) - IEEE = .FALSE. -* - IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN - IF( NGPMIN.EQ.GPMIN ) THEN - LEMIN = NGPMIN -* ( Non twos-complement machines, no gradual underflow; -* e.g., VAX ) - ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN - LEMIN = NGPMIN - 1 + LT - IEEE = .TRUE. -* ( Non twos-complement machines, with gradual underflow; -* e.g., IEEE standard followers ) - ELSE - LEMIN = MIN( NGPMIN, GPMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN - IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN - LEMIN = MAX( NGPMIN, NGNMIN ) -* ( Twos-complement machines, no gradual underflow; -* e.g., CYBER 205 ) - ELSE - LEMIN = MIN( NGPMIN, NGNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND. - $ ( GPMIN.EQ.GNMIN ) ) THEN - IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN - LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT -* ( Twos-complement machines with gradual underflow; -* no known machine ) - ELSE - LEMIN = MIN( NGPMIN, NGNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -* - ELSE - LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN ) -* ( A guess; no known machine ) - IWARN = .TRUE. - END IF -*** -* Comment out this if block if EMIN is ok - IF( IWARN ) THEN - FIRST = .TRUE. - WRITE( 6, FMT = 9999 )LEMIN - END IF -*** -* -* Assume IEEE arithmetic if we found denormalised numbers above, -* or if arithmetic seems to round in the IEEE style, determined -* in routine DLAMC1. A true IEEE machine should have both things -* true; however, faulty machines may have one or the other. -* - IEEE = IEEE .OR. LIEEE1 -* -* Compute RMIN by successive division by BETA. We could compute -* RMIN as BASE**( EMIN - 1 ), but some machines underflow during -* this computation. -* - LRMIN = 1 - DO 30 I = 1, 1 - LEMIN - LRMIN = DLAMC3( LRMIN*RBASE, ZERO ) - 30 CONTINUE -* -* Finally, call DLAMC5 to compute EMAX and RMAX. -* - CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX ) - END IF -* - BETA = LBETA - T = LT - RND = LRND - EPS = LEPS - EMIN = LEMIN - RMIN = LRMIN - EMAX = LEMAX - RMAX = LRMAX -* - RETURN -* - 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-', - $ ' EMIN = ', I8, / - $ ' If, after inspection, the value EMIN looks', - $ ' acceptable please comment out ', - $ / ' the IF block as marked within the code of routine', - $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / ) -* -* End of DLAMC2 -* - END -* -************************************************************************ -* - DOUBLE PRECISION FUNCTION DLAMC3( A, B ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - DOUBLE PRECISION A, B -* .. -* -* Purpose -* ======= -* -* DLAMC3 is intended to force A and B to be stored prior to doing -* the addition of A and B , for use in situations where optimizers -* might hold one of these in a register. -* -* Arguments -* ========= -* -* A, B (input) DOUBLE PRECISION -* The values A and B. -* -* ===================================================================== -* -* .. Executable Statements .. -* - DLAMC3 = A + B -* - RETURN -* -* End of DLAMC3 -* - END -* -************************************************************************ -* - SUBROUTINE DLAMC4( EMIN, START, BASE ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - INTEGER BASE, EMIN - DOUBLE PRECISION START -* .. -* -* Purpose -* ======= -* -* DLAMC4 is a service routine for DLAMC2. -* -* Arguments -* ========= -* -* EMIN (output) EMIN -* The minimum exponent before (gradual) underflow, computed by -* setting A = START and dividing by BASE until the previous A -* can not be recovered. -* -* START (input) DOUBLE PRECISION -* The starting point for determining EMIN. -* -* BASE (input) INTEGER -* The base of the machine. -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I - DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3 - EXTERNAL DLAMC3 -* .. -* .. Executable Statements .. -* - A = START - ONE = 1 - RBASE = ONE / BASE - ZERO = 0 - EMIN = 1 - B1 = DLAMC3( A*RBASE, ZERO ) - C1 = A - C2 = A - D1 = A - D2 = A -*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. -* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP - 10 CONTINUE - IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND. - $ ( D2.EQ.A ) ) THEN - EMIN = EMIN - 1 - A = B1 - B1 = DLAMC3( A / BASE, ZERO ) - C1 = DLAMC3( B1*BASE, ZERO ) - D1 = ZERO - DO 20 I = 1, BASE - D1 = D1 + B1 - 20 CONTINUE - B2 = DLAMC3( A*RBASE, ZERO ) - C2 = DLAMC3( B2 / RBASE, ZERO ) - D2 = ZERO - DO 30 I = 1, BASE - D2 = D2 + B2 - 30 CONTINUE - GO TO 10 - END IF -*+ END WHILE -* - RETURN -* -* End of DLAMC4 -* - END -* -************************************************************************ -* - SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - LOGICAL IEEE - INTEGER BETA, EMAX, EMIN, P - DOUBLE PRECISION RMAX -* .. -* -* Purpose -* ======= -* -* DLAMC5 attempts to compute RMAX, the largest machine floating-point -* number, without overflow. It assumes that EMAX + abs(EMIN) sum -* approximately to a power of 2. It will fail on machines where this -* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, -* EMAX = 28718). It will also fail if the value supplied for EMIN is -* too large (i.e. too close to zero), probably with overflow. -* -* Arguments -* ========= -* -* BETA (input) INTEGER -* The base of floating-point arithmetic. -* -* P (input) INTEGER -* The number of base BETA digits in the mantissa of a -* floating-point value. -* -* EMIN (input) INTEGER -* The minimum exponent before (gradual) underflow. -* -* IEEE (input) LOGICAL -* A logical flag specifying whether or not the arithmetic -* system is thought to comply with the IEEE standard. -* -* EMAX (output) INTEGER -* The largest exponent before overflow -* -* RMAX (output) DOUBLE PRECISION -* The largest machine floating-point number. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP - DOUBLE PRECISION OLDY, RECBAS, Y, Z -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMC3 - EXTERNAL DLAMC3 -* .. -* .. Intrinsic Functions .. - INTRINSIC MOD -* .. -* .. Executable Statements .. -* -* First compute LEXP and UEXP, two powers of 2 that bound -* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum -* approximately to the bound that is closest to abs(EMIN). -* (EMAX is the exponent of the required number RMAX). -* - LEXP = 1 - EXBITS = 1 - 10 CONTINUE - TRY = LEXP*2 - IF( TRY.LE.( -EMIN ) ) THEN - LEXP = TRY - EXBITS = EXBITS + 1 - GO TO 10 - END IF - IF( LEXP.EQ.-EMIN ) THEN - UEXP = LEXP - ELSE - UEXP = TRY - EXBITS = EXBITS + 1 - END IF -* -* Now -LEXP is less than or equal to EMIN, and -UEXP is greater -* than or equal to EMIN. EXBITS is the number of bits needed to -* store the exponent. -* - IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN - EXPSUM = 2*LEXP - ELSE - EXPSUM = 2*UEXP - END IF -* -* EXPSUM is the exponent range, approximately equal to -* EMAX - EMIN + 1 . -* - EMAX = EXPSUM + EMIN - 1 - NBITS = 1 + EXBITS + P -* -* NBITS is the total number of bits needed to store a -* floating-point number. -* - IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN -* -* Either there are an odd number of bits used to store a -* floating-point number, which is unlikely, or some bits are -* not used in the representation of numbers, which is possible, -* (e.g. Cray machines) or the mantissa has an implicit bit, -* (e.g. IEEE machines, Dec Vax machines), which is perhaps the -* most likely. We have to assume the last alternative. -* If this is true, then we need to reduce EMAX by one because -* there must be some way of representing zero in an implicit-bit -* system. On machines like Cray, we are reducing EMAX by one -* unnecessarily. -* - EMAX = EMAX - 1 - END IF -* - IF( IEEE ) THEN -* -* Assume we are on an IEEE machine which reserves one exponent -* for infinity and NaN. -* - EMAX = EMAX - 1 - END IF -* -* Now create RMAX, the largest machine number, which should -* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . -* -* First compute 1.0 - BETA**(-P), being careful that the -* result is less than 1.0 . -* - RECBAS = ONE / BETA - Z = BETA - ONE - Y = ZERO - DO 20 I = 1, P - Z = Z*RECBAS - IF( Y.LT.ONE ) - $ OLDY = Y - Y = DLAMC3( Y, Z ) - 20 CONTINUE - IF( Y.GE.ONE ) - $ Y = OLDY -* -* Now multiply by BETA**EMAX to get RMAX. -* - DO 30 I = 1, EMAX - Y = DLAMC3( Y*BETA, ZERO ) - 30 CONTINUE -* - RMAX = Y - RETURN -* -* End of DLAMC5 -* - END diff --git a/ext/lapack/dlange.f b/ext/lapack/dlange.f deleted file mode 100644 index 0737f03ea..000000000 --- a/ext/lapack/dlange.f +++ /dev/null @@ -1,145 +0,0 @@ - DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER NORM - INTEGER LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLANGE returns the value of the one norm, or the Frobenius norm, or -* the infinity norm, or the element of largest absolute value of a -* real matrix A. -* -* Description -* =========== -* -* DLANGE returns the value -* -* DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' -* ( -* ( norm1(A), NORM = '1', 'O' or 'o' -* ( -* ( normI(A), NORM = 'I' or 'i' -* ( -* ( normF(A), NORM = 'F', 'f', 'E' or 'e' -* -* where norm1 denotes the one norm of a matrix (maximum column sum), -* normI denotes the infinity norm of a matrix (maximum row sum) and -* normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies the value to be returned in DLANGE as described -* above. -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. When M = 0, -* DLANGE is set to zero. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. When N = 0, -* DLANGE is set to zero. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The m by n matrix A. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(M,1). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), -* where LWORK >= M when NORM = 'I'; otherwise, WORK is not -* referenced. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION SCALE, SUM, VALUE -* .. -* .. External Subroutines .. - EXTERNAL DLASSQ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - IF( MIN( M, N ).EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - VALUE = ZERO - DO 20 J = 1, N - DO 10 I = 1, M - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 10 CONTINUE - 20 CONTINUE - ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN -* -* Find norm1(A). -* - VALUE = ZERO - DO 40 J = 1, N - SUM = ZERO - DO 30 I = 1, M - SUM = SUM + ABS( A( I, J ) ) - 30 CONTINUE - VALUE = MAX( VALUE, SUM ) - 40 CONTINUE - ELSE IF( LSAME( NORM, 'I' ) ) THEN -* -* Find normI(A). -* - DO 50 I = 1, M - WORK( I ) = ZERO - 50 CONTINUE - DO 70 J = 1, N - DO 60 I = 1, M - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) - 60 CONTINUE - 70 CONTINUE - VALUE = ZERO - DO 80 I = 1, M - VALUE = MAX( VALUE, WORK( I ) ) - 80 CONTINUE - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - SCALE = ZERO - SUM = ONE - DO 90 J = 1, N - CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM ) - 90 CONTINUE - VALUE = SCALE*SQRT( SUM ) - END IF -* - DLANGE = VALUE - RETURN -* -* End of DLANGE -* - END diff --git a/ext/lapack/dlantr.f b/ext/lapack/dlantr.f deleted file mode 100644 index 19e9b5d92..000000000 --- a/ext/lapack/dlantr.f +++ /dev/null @@ -1,277 +0,0 @@ - DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA, - $ WORK ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIAG, NORM, UPLO - INTEGER LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLANTR returns the value of the one norm, or the Frobenius norm, or -* the infinity norm, or the element of largest absolute value of a -* trapezoidal or triangular matrix A. -* -* Description -* =========== -* -* DLANTR returns the value -* -* DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm' -* ( -* ( norm1(A), NORM = '1', 'O' or 'o' -* ( -* ( normI(A), NORM = 'I' or 'i' -* ( -* ( normF(A), NORM = 'F', 'f', 'E' or 'e' -* -* where norm1 denotes the one norm of a matrix (maximum column sum), -* normI denotes the infinity norm of a matrix (maximum row sum) and -* normF denotes the Frobenius norm of a matrix (square root of sum of -* squares). Note that max(abs(A(i,j))) is not a matrix norm. -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies the value to be returned in DLANTR as described -* above. -* -* UPLO (input) CHARACTER*1 -* Specifies whether the matrix A is upper or lower trapezoidal. -* = 'U': Upper trapezoidal -* = 'L': Lower trapezoidal -* Note that A is triangular instead of trapezoidal if M = N. -* -* DIAG (input) CHARACTER*1 -* Specifies whether or not the matrix A has unit diagonal. -* = 'N': Non-unit diagonal -* = 'U': Unit diagonal -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0, and if -* UPLO = 'U', M <= N. When M = 0, DLANTR is set to zero. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0, and if -* UPLO = 'L', N <= M. When N = 0, DLANTR is set to zero. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The trapezoidal matrix A (A is triangular if M = N). -* If UPLO = 'U', the leading m by n upper trapezoidal part of -* the array A contains the upper trapezoidal matrix, and the -* strictly lower triangular part of A is not referenced. -* If UPLO = 'L', the leading m by n lower trapezoidal part of -* the array A contains the lower trapezoidal matrix, and the -* strictly upper triangular part of A is not referenced. Note -* that when DIAG = 'U', the diagonal elements of A are not -* referenced and are assumed to be one. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(M,1). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK), -* where LWORK >= M when NORM = 'I'; otherwise, WORK is not -* referenced. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UDIAG - INTEGER I, J - DOUBLE PRECISION SCALE, SUM, VALUE -* .. -* .. External Subroutines .. - EXTERNAL DLASSQ -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - IF( MIN( M, N ).EQ.0 ) THEN - VALUE = ZERO - ELSE IF( LSAME( NORM, 'M' ) ) THEN -* -* Find max(abs(A(i,j))). -* - IF( LSAME( DIAG, 'U' ) ) THEN - VALUE = ONE - IF( LSAME( UPLO, 'U' ) ) THEN - DO 20 J = 1, N - DO 10 I = 1, MIN( M, J-1 ) - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 10 CONTINUE - 20 CONTINUE - ELSE - DO 40 J = 1, N - DO 30 I = J + 1, M - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 30 CONTINUE - 40 CONTINUE - END IF - ELSE - VALUE = ZERO - IF( LSAME( UPLO, 'U' ) ) THEN - DO 60 J = 1, N - DO 50 I = 1, MIN( M, J ) - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 50 CONTINUE - 60 CONTINUE - ELSE - DO 80 J = 1, N - DO 70 I = J, M - VALUE = MAX( VALUE, ABS( A( I, J ) ) ) - 70 CONTINUE - 80 CONTINUE - END IF - END IF - ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN -* -* Find norm1(A). -* - VALUE = ZERO - UDIAG = LSAME( DIAG, 'U' ) - IF( LSAME( UPLO, 'U' ) ) THEN - DO 110 J = 1, N - IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN - SUM = ONE - DO 90 I = 1, J - 1 - SUM = SUM + ABS( A( I, J ) ) - 90 CONTINUE - ELSE - SUM = ZERO - DO 100 I = 1, MIN( M, J ) - SUM = SUM + ABS( A( I, J ) ) - 100 CONTINUE - END IF - VALUE = MAX( VALUE, SUM ) - 110 CONTINUE - ELSE - DO 140 J = 1, N - IF( UDIAG ) THEN - SUM = ONE - DO 120 I = J + 1, M - SUM = SUM + ABS( A( I, J ) ) - 120 CONTINUE - ELSE - SUM = ZERO - DO 130 I = J, M - SUM = SUM + ABS( A( I, J ) ) - 130 CONTINUE - END IF - VALUE = MAX( VALUE, SUM ) - 140 CONTINUE - END IF - ELSE IF( LSAME( NORM, 'I' ) ) THEN -* -* Find normI(A). -* - IF( LSAME( UPLO, 'U' ) ) THEN - IF( LSAME( DIAG, 'U' ) ) THEN - DO 150 I = 1, M - WORK( I ) = ONE - 150 CONTINUE - DO 170 J = 1, N - DO 160 I = 1, MIN( M, J-1 ) - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) - 160 CONTINUE - 170 CONTINUE - ELSE - DO 180 I = 1, M - WORK( I ) = ZERO - 180 CONTINUE - DO 200 J = 1, N - DO 190 I = 1, MIN( M, J ) - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) - 190 CONTINUE - 200 CONTINUE - END IF - ELSE - IF( LSAME( DIAG, 'U' ) ) THEN - DO 210 I = 1, N - WORK( I ) = ONE - 210 CONTINUE - DO 220 I = N + 1, M - WORK( I ) = ZERO - 220 CONTINUE - DO 240 J = 1, N - DO 230 I = J + 1, M - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) - 230 CONTINUE - 240 CONTINUE - ELSE - DO 250 I = 1, M - WORK( I ) = ZERO - 250 CONTINUE - DO 270 J = 1, N - DO 260 I = J, M - WORK( I ) = WORK( I ) + ABS( A( I, J ) ) - 260 CONTINUE - 270 CONTINUE - END IF - END IF - VALUE = ZERO - DO 280 I = 1, M - VALUE = MAX( VALUE, WORK( I ) ) - 280 CONTINUE - ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN -* -* Find normF(A). -* - IF( LSAME( UPLO, 'U' ) ) THEN - IF( LSAME( DIAG, 'U' ) ) THEN - SCALE = ONE - SUM = MIN( M, N ) - DO 290 J = 2, N - CALL DLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM ) - 290 CONTINUE - ELSE - SCALE = ZERO - SUM = ONE - DO 300 J = 1, N - CALL DLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM ) - 300 CONTINUE - END IF - ELSE - IF( LSAME( DIAG, 'U' ) ) THEN - SCALE = ONE - SUM = MIN( M, N ) - DO 310 J = 1, N - CALL DLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE, - $ SUM ) - 310 CONTINUE - ELSE - SCALE = ZERO - SUM = ONE - DO 320 J = 1, N - CALL DLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM ) - 320 CONTINUE - END IF - END IF - VALUE = SCALE*SQRT( SUM ) - END IF -* - DLANTR = VALUE - RETURN -* -* End of DLANTR -* - END diff --git a/ext/lapack/dlapy2.f b/ext/lapack/dlapy2.f deleted file mode 100644 index d38196132..000000000 --- a/ext/lapack/dlapy2.f +++ /dev/null @@ -1,54 +0,0 @@ - DOUBLE PRECISION FUNCTION DLAPY2( X, Y ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - DOUBLE PRECISION X, Y -* .. -* -* Purpose -* ======= -* -* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary -* overflow. -* -* Arguments -* ========= -* -* X (input) DOUBLE PRECISION -* Y (input) DOUBLE PRECISION -* X and Y specify the values x and y. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION W, XABS, YABS, Z -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - XABS = ABS( X ) - YABS = ABS( Y ) - W = MAX( XABS, YABS ) - Z = MIN( XABS, YABS ) - IF( Z.EQ.ZERO ) THEN - DLAPY2 = W - ELSE - DLAPY2 = W*SQRT( ONE+( Z / W )**2 ) - END IF - RETURN -* -* End of DLAPY2 -* - END diff --git a/ext/lapack/dlarf.f b/ext/lapack/dlarf.f deleted file mode 100644 index 1bb357f9b..000000000 --- a/ext/lapack/dlarf.f +++ /dev/null @@ -1,116 +0,0 @@ - SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER SIDE - INTEGER INCV, LDC, M, N - DOUBLE PRECISION TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLARF applies a real elementary reflector H to a real m by n matrix -* C, from either the left or the right. H is represented in the form -* -* H = I - tau * v * v' -* -* where tau is a real scalar and v is a real vector. -* -* If tau = 0, then H is taken to be the unit matrix. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': form H * C -* = 'R': form C * H -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* V (input) DOUBLE PRECISION array, dimension -* (1 + (M-1)*abs(INCV)) if SIDE = 'L' -* or (1 + (N-1)*abs(INCV)) if SIDE = 'R' -* The vector v in the representation of H. V is not used if -* TAU = 0. -* -* INCV (input) INTEGER -* The increment between elements of v. INCV <> 0. -* -* TAU (input) DOUBLE PRECISION -* The value tau in the representation of H. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by the matrix H * C if SIDE = 'L', -* or C * H if SIDE = 'R'. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* (N) if SIDE = 'L' -* or (M) if SIDE = 'R' -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DGER -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C -* - IF( TAU.NE.ZERO ) THEN -* -* w := C' * v -* - CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO, - $ WORK, 1 ) -* -* C := C - v * w' -* - CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC ) - END IF - ELSE -* -* Form C * H -* - IF( TAU.NE.ZERO ) THEN -* -* w := C * v -* - CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV, - $ ZERO, WORK, 1 ) -* -* C := C - w * v' -* - CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC ) - END IF - END IF - RETURN -* -* End of DLARF -* - END diff --git a/ext/lapack/dlarfb.f b/ext/lapack/dlarfb.f deleted file mode 100644 index 4e4f18600..000000000 --- a/ext/lapack/dlarfb.f +++ /dev/null @@ -1,588 +0,0 @@ - SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, - $ T, LDT, C, LDC, WORK, LDWORK ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIRECT, SIDE, STOREV, TRANS - INTEGER K, LDC, LDT, LDV, LDWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ), - $ WORK( LDWORK, * ) -* .. -* -* Purpose -* ======= -* -* DLARFB applies a real block reflector H or its transpose H' to a -* real m by n matrix C, from either the left or the right. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply H or H' from the Left -* = 'R': apply H or H' from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply H (No transpose) -* = 'T': apply H' (Transpose) -* -* DIRECT (input) CHARACTER*1 -* Indicates how H is formed from a product of elementary -* reflectors -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Indicates how the vectors which define the elementary -* reflectors are stored: -* = 'C': Columnwise -* = 'R': Rowwise -* -* M (input) INTEGER -* The number of rows of the matrix C. -* -* N (input) INTEGER -* The number of columns of the matrix C. -* -* K (input) INTEGER -* The order of the matrix T (= the number of elementary -* reflectors whose product defines the block reflector). -* -* V (input) DOUBLE PRECISION array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,M) if STOREV = 'R' and SIDE = 'L' -* (LDV,N) if STOREV = 'R' and SIDE = 'R' -* The matrix V. See further details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); -* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); -* if STOREV = 'R', LDV >= K. -* -* T (input) DOUBLE PRECISION array, dimension (LDT,K) -* The triangular k by k matrix T in the representation of the -* block reflector. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by H*C or H'*C or C*H or C*H'. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDA >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) -* -* LDWORK (input) INTEGER -* The leading dimension of the array WORK. -* If SIDE = 'L', LDWORK >= max(1,N); -* if SIDE = 'R', LDWORK >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - CHARACTER TRANST - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DGEMM, DTRMM -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( M.LE.0 .OR. N.LE.0 ) - $ RETURN -* - IF( LSAME( TRANS, 'N' ) ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* - IF( LSAME( STOREV, 'C' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 ) (first K rows) -* ( V2 ) -* where V1 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) -* -* W := C1' -* - DO 10 J = 1, K - CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 10 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2'*V2 -* - CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, - $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W' -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2 * W' -* - CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, - $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1' -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, - $ ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W' -* - DO 30 J = 1, K - DO 20 I = 1, N - C( J, I ) = C( J, I ) - WORK( I, J ) - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C1 -* - DO 40 J = 1, K - CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 40 CONTINUE -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, - $ K, ONE, V, LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C2 * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, - $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V' -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2' -* - CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1' -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, - $ ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 60 J = 1, K - DO 50 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 50 CONTINUE - 60 CONTINUE - END IF -* - ELSE -* -* Let V = ( V1 ) -* ( V2 ) (last K rows) -* where V2 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) -* -* W := C2' -* - DO 70 J = 1, K - CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) - 70 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, - $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C1'*V1 -* - CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V * W' -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1 * W' -* - CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K, - $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC ) - END IF -* -* W := W * V2' -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, - $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W' -* - DO 90 J = 1, K - DO 80 I = 1, N - C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V = (C1*V1 + C2*V2) (stored in WORK) -* -* W := C2 -* - DO 100 J = 1, K - CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 100 CONTINUE -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, - $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C1 * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V' -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1' -* - CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) - END IF -* -* W := W * V2' -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, - $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W -* - DO 120 J = 1, K - DO 110 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 110 CONTINUE - 120 CONTINUE - END IF - END IF -* - ELSE IF( LSAME( STOREV, 'R' ) ) THEN -* - IF( LSAME( DIRECT, 'F' ) ) THEN -* -* Let V = ( V1 V2 ) (V1: first K columns) -* where V1 is unit upper triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) -* -* W := C1' -* - DO 130 J = 1, K - CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 ) - 130 CONTINUE -* -* W := W * V1' -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K, - $ ONE, V, LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C2'*V2' -* - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE, - $ WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V' * W' -* - IF( M.GT.K ) THEN -* -* C2 := C2 - V2' * W' -* - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, - $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE, - $ C( K+1, 1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W' -* - DO 150 J = 1, K - DO 140 I = 1, N - C( J, I ) = C( J, I ) - WORK( I, J ) - 140 CONTINUE - 150 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) -* -* W := C1 -* - DO 160 J = 1, K - CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 ) - 160 CONTINUE -* -* W := W * V1' -* - CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K, - $ ONE, V, LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C2 * V2' -* - CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, - $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV, - $ ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C2 := C2 - W * V2 -* - CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE, - $ C( 1, K+1 ), LDC ) - END IF -* -* W := W * V1 -* - CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M, - $ K, ONE, V, LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 180 J = 1, K - DO 170 I = 1, M - C( I, J ) = C( I, J ) - WORK( I, J ) - 170 CONTINUE - 180 CONTINUE -* - END IF -* - ELSE -* -* Let V = ( V1 V2 ) (V2: last K columns) -* where V2 is unit lower triangular. -* - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form H * C or H' * C where C = ( C1 ) -* ( C2 ) -* -* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) -* -* W := C2' -* - DO 190 J = 1, K - CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 ) - 190 CONTINUE -* -* W := W * V2' -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K, - $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) - IF( M.GT.K ) THEN -* -* W := W + C1'*V1' -* - CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE, - $ C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T' or W * T -* - CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - V' * W' -* - IF( M.GT.K ) THEN -* -* C1 := C1 - V1' * W' -* - CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE, - $ V, LDV, WORK, LDWORK, ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N, - $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK ) -* -* C2 := C2 - W' -* - DO 210 J = 1, K - DO 200 I = 1, N - C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J ) - 200 CONTINUE - 210 CONTINUE -* - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form C * H or C * H' where C = ( C1 C2 ) -* -* W := C * V' = (C1*V1' + C2*V2') (stored in WORK) -* -* W := C2 -* - DO 220 J = 1, K - CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 ) - 220 CONTINUE -* -* W := W * V2' -* - CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K, - $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) - IF( N.GT.K ) THEN -* -* W := W + C1 * V1' -* - CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K, - $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK ) - END IF -* -* W := W * T or W * T' -* - CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, - $ ONE, T, LDT, WORK, LDWORK ) -* -* C := C - W * V -* - IF( N.GT.K ) THEN -* -* C1 := C1 - W * V1 -* - CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K, - $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC ) - END IF -* -* W := W * V2 -* - CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M, - $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK ) -* -* C1 := C1 - W -* - DO 240 J = 1, K - DO 230 I = 1, M - C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J ) - 230 CONTINUE - 240 CONTINUE -* - END IF -* - END IF - END IF -* - RETURN -* -* End of DLARFB -* - END diff --git a/ext/lapack/dlarfg.f b/ext/lapack/dlarfg.f deleted file mode 100644 index a8e64c1b9..000000000 --- a/ext/lapack/dlarfg.f +++ /dev/null @@ -1,138 +0,0 @@ - SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION ALPHA, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* Purpose -* ======= -* -* DLARFG generates a real elementary reflector H of order n, such -* that -* -* H * ( alpha ) = ( beta ), H' * H = I. -* ( x ) ( 0 ) -* -* where alpha and beta are scalars, and x is an (n-1)-element real -* vector. H is represented in the form -* -* H = I - tau * ( 1 ) * ( 1 v' ) , -* ( v ) -* -* where tau is a real scalar and v is a real (n-1)-element -* vector. -* -* If the elements of x are all zero, then tau = 0 and H is taken to be -* the unit matrix. -* -* Otherwise 1 <= tau <= 2. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The order of the elementary reflector. -* -* ALPHA (input/output) DOUBLE PRECISION -* On entry, the value alpha. -* On exit, it is overwritten with the value beta. -* -* X (input/output) DOUBLE PRECISION array, dimension -* (1+(N-2)*abs(INCX)) -* On entry, the vector x. -* On exit, it is overwritten with the vector v. -* -* INCX (input) INTEGER -* The increment between elements of X. INCX > 0. -* -* TAU (output) DOUBLE PRECISION -* The value tau. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER J, KNT - DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2 - EXTERNAL DLAMCH, DLAPY2, DNRM2 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN -* .. -* .. External Subroutines .. - EXTERNAL DSCAL -* .. -* .. Executable Statements .. -* - IF( N.LE.1 ) THEN - TAU = ZERO - RETURN - END IF -* - XNORM = DNRM2( N-1, X, INCX ) -* - IF( XNORM.EQ.ZERO ) THEN -* -* H = I -* - TAU = ZERO - ELSE -* -* general case -* - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' ) - IF( ABS( BETA ).LT.SAFMIN ) THEN -* -* XNORM, BETA may be inaccurate; scale X and recompute them -* - RSAFMN = ONE / SAFMIN - KNT = 0 - 10 CONTINUE - KNT = KNT + 1 - CALL DSCAL( N-1, RSAFMN, X, INCX ) - BETA = BETA*RSAFMN - ALPHA = ALPHA*RSAFMN - IF( ABS( BETA ).LT.SAFMIN ) - $ GO TO 10 -* -* New BETA is at most 1, at least SAFMIN -* - XNORM = DNRM2( N-1, X, INCX ) - BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA ) - TAU = ( BETA-ALPHA ) / BETA - CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) -* -* If ALPHA is subnormal, it may lose relative accuracy -* - ALPHA = BETA - DO 20 J = 1, KNT - ALPHA = ALPHA*SAFMIN - 20 CONTINUE - ELSE - TAU = ( BETA-ALPHA ) / BETA - CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX ) - ALPHA = BETA - END IF - END IF -* - RETURN -* -* End of DLARFG -* - END diff --git a/ext/lapack/dlarft.f b/ext/lapack/dlarft.f deleted file mode 100644 index 6035df482..000000000 --- a/ext/lapack/dlarft.f +++ /dev/null @@ -1,218 +0,0 @@ - SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIRECT, STOREV - INTEGER K, LDT, LDV, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) -* .. -* -* Purpose -* ======= -* -* DLARFT forms the triangular factor T of a real block reflector H -* of order n, which is defined as a product of k elementary reflectors. -* -* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; -* -* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. -* -* If STOREV = 'C', the vector which defines the elementary reflector -* H(i) is stored in the i-th column of the array V, and -* -* H = I - V * T * V' -* -* If STOREV = 'R', the vector which defines the elementary reflector -* H(i) is stored in the i-th row of the array V, and -* -* H = I - V' * T * V -* -* Arguments -* ========= -* -* DIRECT (input) CHARACTER*1 -* Specifies the order in which the elementary reflectors are -* multiplied to form the block reflector: -* = 'F': H = H(1) H(2) . . . H(k) (Forward) -* = 'B': H = H(k) . . . H(2) H(1) (Backward) -* -* STOREV (input) CHARACTER*1 -* Specifies how the vectors which define the elementary -* reflectors are stored (see also Further Details): -* = 'C': columnwise -* = 'R': rowwise -* -* N (input) INTEGER -* The order of the block reflector H. N >= 0. -* -* K (input) INTEGER -* The order of the triangular factor T (= the number of -* elementary reflectors). K >= 1. -* -* V (input/output) DOUBLE PRECISION array, dimension -* (LDV,K) if STOREV = 'C' -* (LDV,N) if STOREV = 'R' -* The matrix V. See further details. -* -* LDV (input) INTEGER -* The leading dimension of the array V. -* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i). -* -* T (output) DOUBLE PRECISION array, dimension (LDT,K) -* The k by k triangular factor T of the block reflector. -* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is -* lower triangular. The rest of the array is not used. -* -* LDT (input) INTEGER -* The leading dimension of the array T. LDT >= K. -* -* Further Details -* =============== -* -* The shape of the matrix V and the storage of the vectors which define -* the H(i) is best illustrated by the following example with n = 5 and -* k = 3. The elements equal to 1 are not stored; the corresponding -* array elements are modified but restored on exit. The rest of the -* array is not used. -* -* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': -* -* V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) -* ( v1 1 ) ( 1 v2 v2 v2 ) -* ( v1 v2 1 ) ( 1 v3 v3 ) -* ( v1 v2 v3 ) -* ( v1 v2 v3 ) -* -* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': -* -* V = ( v1 v2 v3 ) V = ( v1 v1 1 ) -* ( v1 v2 v3 ) ( v2 v2 v2 1 ) -* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) -* ( 1 v3 ) -* ( 1 ) -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J - DOUBLE PRECISION VII -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DTRMV -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 20 I = 1, K - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 10 J = 1, I - T( J, I ) = ZERO - 10 CONTINUE - ELSE -* -* general case -* - VII = V( I, I ) - V( I, I ) = ONE - IF( LSAME( STOREV, 'C' ) ) THEN -* -* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i) -* - CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ), - $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, - $ T( 1, I ), 1 ) - ELSE -* -* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)' -* - CALL DGEMV( 'No transpose', I-1, N-I+1, -TAU( I ), - $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, - $ T( 1, I ), 1 ) - END IF - V( I, I ) = VII -* -* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) -* - CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, - $ LDT, T( 1, I ), 1 ) - T( I, I ) = TAU( I ) - END IF - 20 CONTINUE - ELSE - DO 40 I = K, 1, -1 - IF( TAU( I ).EQ.ZERO ) THEN -* -* H(i) = I -* - DO 30 J = I, K - T( J, I ) = ZERO - 30 CONTINUE - ELSE -* -* general case -* - IF( I.LT.K ) THEN - IF( LSAME( STOREV, 'C' ) ) THEN - VII = V( N-K+I, I ) - V( N-K+I, I ) = ONE -* -* T(i+1:k,i) := -* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i) -* - CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ), - $ V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO, - $ T( I+1, I ), 1 ) - V( N-K+I, I ) = VII - ELSE - VII = V( I, N-K+I ) - V( I, N-K+I ) = ONE -* -* T(i+1:k,i) := -* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)' -* - CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ), - $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO, - $ T( I+1, I ), 1 ) - V( I, N-K+I ) = VII - END IF -* -* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) -* - CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I, - $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 ) - END IF - T( I, I ) = TAU( I ) - END IF - 40 CONTINUE - END IF - RETURN -* -* End of DLARFT -* - END diff --git a/ext/lapack/dlartg.f b/ext/lapack/dlartg.f deleted file mode 100644 index 502f13eeb..000000000 --- a/ext/lapack/dlartg.f +++ /dev/null @@ -1,143 +0,0 @@ - SUBROUTINE DLARTG( F, G, CS, SN, R ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - DOUBLE PRECISION CS, F, G, R, SN -* .. -* -* Purpose -* ======= -* -* DLARTG generate a plane rotation so that -* -* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. -* [ -SN CS ] [ G ] [ 0 ] -* -* This is a slower, more accurate version of the BLAS1 routine DROTG, -* with the following other differences: -* F and G are unchanged on return. -* If G=0, then CS=1 and SN=0. -* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any -* floating point operations (saves work in DBDSQR when -* there are zeros on the diagonal). -* -* If F exceeds G in magnitude, CS will be positive. -* -* Arguments -* ========= -* -* F (input) DOUBLE PRECISION -* The first component of vector to be rotated. -* -* G (input) DOUBLE PRECISION -* The second component of vector to be rotated. -* -* CS (output) DOUBLE PRECISION -* The cosine of the rotation. -* -* SN (output) DOUBLE PRECISION -* The sine of the rotation. -* -* R (output) DOUBLE PRECISION -* The nonzero component of the rotated vector. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL FIRST - INTEGER COUNT, I - DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, INT, LOG, MAX, SQRT -* .. -* .. Save statement .. - SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 -* .. -* .. Data statements .. - DATA FIRST / .TRUE. / -* .. -* .. Executable Statements .. -* - IF( FIRST ) THEN - FIRST = .FALSE. - SAFMIN = DLAMCH( 'S' ) - EPS = DLAMCH( 'E' ) - SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) / - $ LOG( DLAMCH( 'B' ) ) / TWO ) - SAFMX2 = ONE / SAFMN2 - END IF - IF( G.EQ.ZERO ) THEN - CS = ONE - SN = ZERO - R = F - ELSE IF( F.EQ.ZERO ) THEN - CS = ZERO - SN = ONE - R = G - ELSE - F1 = F - G1 = G - SCALE = MAX( ABS( F1 ), ABS( G1 ) ) - IF( SCALE.GE.SAFMX2 ) THEN - COUNT = 0 - 10 CONTINUE - COUNT = COUNT + 1 - F1 = F1*SAFMN2 - G1 = G1*SAFMN2 - SCALE = MAX( ABS( F1 ), ABS( G1 ) ) - IF( SCALE.GE.SAFMX2 ) - $ GO TO 10 - R = SQRT( F1**2+G1**2 ) - CS = F1 / R - SN = G1 / R - DO 20 I = 1, COUNT - R = R*SAFMX2 - 20 CONTINUE - ELSE IF( SCALE.LE.SAFMN2 ) THEN - COUNT = 0 - 30 CONTINUE - COUNT = COUNT + 1 - F1 = F1*SAFMX2 - G1 = G1*SAFMX2 - SCALE = MAX( ABS( F1 ), ABS( G1 ) ) - IF( SCALE.LE.SAFMN2 ) - $ GO TO 30 - R = SQRT( F1**2+G1**2 ) - CS = F1 / R - SN = G1 / R - DO 40 I = 1, COUNT - R = R*SAFMN2 - 40 CONTINUE - ELSE - R = SQRT( F1**2+G1**2 ) - CS = F1 / R - SN = G1 / R - END IF - IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN - CS = -CS - SN = -SN - R = -R - END IF - END IF - RETURN -* -* End of DLARTG -* - END diff --git a/ext/lapack/dlas2.f b/ext/lapack/dlas2.f deleted file mode 100644 index ad2f337dc..000000000 --- a/ext/lapack/dlas2.f +++ /dev/null @@ -1,122 +0,0 @@ - SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - DOUBLE PRECISION F, G, H, SSMAX, SSMIN -* .. -* -* Purpose -* ======= -* -* DLAS2 computes the singular values of the 2-by-2 matrix -* [ F G ] -* [ 0 H ]. -* On return, SSMIN is the smaller singular value and SSMAX is the -* larger singular value. -* -* Arguments -* ========= -* -* F (input) DOUBLE PRECISION -* The (1,1) element of the 2-by-2 matrix. -* -* G (input) DOUBLE PRECISION -* The (1,2) element of the 2-by-2 matrix. -* -* H (input) DOUBLE PRECISION -* The (2,2) element of the 2-by-2 matrix. -* -* SSMIN (output) DOUBLE PRECISION -* The smaller singular value. -* -* SSMAX (output) DOUBLE PRECISION -* The larger singular value. -* -* Further Details -* =============== -* -* Barring over/underflow, all output quantities are correct to within -* a few units in the last place (ulps), even in the absence of a guard -* digit in addition/subtraction. -* -* In IEEE arithmetic, the code works correctly if one matrix element is -* infinite. -* -* Overflow will not occur unless the largest singular value itself -* overflows, or is within a few ulps of overflow. (On machines with -* partial overflow, like the Cray, overflow may occur if the largest -* singular value is within a factor of 2 of overflow.) -* -* Underflow is harmless if underflow is gradual. Otherwise, results -* may correspond to a matrix modified by perturbations of size near -* the underflow threshold. -* -* ==================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) -* .. -* .. Local Scalars .. - DOUBLE PRECISION AS, AT, AU, C, FA, FHMN, FHMX, GA, HA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. -* - FA = ABS( F ) - GA = ABS( G ) - HA = ABS( H ) - FHMN = MIN( FA, HA ) - FHMX = MAX( FA, HA ) - IF( FHMN.EQ.ZERO ) THEN - SSMIN = ZERO - IF( FHMX.EQ.ZERO ) THEN - SSMAX = GA - ELSE - SSMAX = MAX( FHMX, GA )*SQRT( ONE+ - $ ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 ) - END IF - ELSE - IF( GA.LT.FHMX ) THEN - AS = ONE + FHMN / FHMX - AT = ( FHMX-FHMN ) / FHMX - AU = ( GA / FHMX )**2 - C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) ) - SSMIN = FHMN*C - SSMAX = FHMX / C - ELSE - AU = FHMX / GA - IF( AU.EQ.ZERO ) THEN -* -* Avoid possible harmful underflow if exponent range -* asymmetric (true SSMIN may not underflow even if -* AU underflows) -* - SSMIN = ( FHMN*FHMX ) / GA - SSMAX = GA - ELSE - AS = ONE + FHMN / FHMX - AT = ( FHMX-FHMN ) / FHMX - C = ONE / ( SQRT( ONE+( AS*AU )**2 )+ - $ SQRT( ONE+( AT*AU )**2 ) ) - SSMIN = ( FHMN*C )*AU - SSMIN = SSMIN + SSMIN - SSMAX = GA / ( C+C ) - END IF - END IF - END IF - RETURN -* -* End of DLAS2 -* - END diff --git a/ext/lapack/dlascl.f b/ext/lapack/dlascl.f deleted file mode 100644 index a4d53852e..000000000 --- a/ext/lapack/dlascl.f +++ /dev/null @@ -1,268 +0,0 @@ - SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER TYPE - INTEGER INFO, KL, KU, LDA, M, N - DOUBLE PRECISION CFROM, CTO -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASCL multiplies the M by N real matrix A by the real scalar -* CTO/CFROM. This is done without over/underflow as long as the final -* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that -* A may be full, upper triangular, lower triangular, upper Hessenberg, -* or banded. -* -* Arguments -* ========= -* -* TYPE (input) CHARACTER*1 -* TYPE indices the storage type of the input matrix. -* = 'G': A is a full matrix. -* = 'L': A is a lower triangular matrix. -* = 'U': A is an upper triangular matrix. -* = 'H': A is an upper Hessenberg matrix. -* = 'B': A is a symmetric band matrix with lower bandwidth KL -* and upper bandwidth KU and with the only the lower -* half stored. -* = 'Q': A is a symmetric band matrix with lower bandwidth KL -* and upper bandwidth KU and with the only the upper -* half stored. -* = 'Z': A is a band matrix with lower bandwidth KL and upper -* bandwidth KU. -* -* KL (input) INTEGER -* The lower bandwidth of A. Referenced only if TYPE = 'B', -* 'Q' or 'Z'. -* -* KU (input) INTEGER -* The upper bandwidth of A. Referenced only if TYPE = 'B', -* 'Q' or 'Z'. -* -* CFROM (input) DOUBLE PRECISION -* CTO (input) DOUBLE PRECISION -* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed -* without over/underflow if the final result CTO*A(I,J)/CFROM -* can be represented without over/underflow. CFROM must be -* nonzero. -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,M) -* The matrix to be multiplied by CTO/CFROM. See TYPE for the -* storage type. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* INFO (output) INTEGER -* 0 - successful exit -* <0 - if INFO = -i, the i-th argument had an illegal value. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL DONE - INTEGER I, ITYPE, J, K1, K2, K3, K4 - DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DLAMCH - EXTERNAL LSAME, DLAMCH -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 -* - IF( LSAME( TYPE, 'G' ) ) THEN - ITYPE = 0 - ELSE IF( LSAME( TYPE, 'L' ) ) THEN - ITYPE = 1 - ELSE IF( LSAME( TYPE, 'U' ) ) THEN - ITYPE = 2 - ELSE IF( LSAME( TYPE, 'H' ) ) THEN - ITYPE = 3 - ELSE IF( LSAME( TYPE, 'B' ) ) THEN - ITYPE = 4 - ELSE IF( LSAME( TYPE, 'Q' ) ) THEN - ITYPE = 5 - ELSE IF( LSAME( TYPE, 'Z' ) ) THEN - ITYPE = 6 - ELSE - ITYPE = -1 - END IF -* - IF( ITYPE.EQ.-1 ) THEN - INFO = -1 - ELSE IF( CFROM.EQ.ZERO ) THEN - INFO = -4 - ELSE IF( M.LT.0 ) THEN - INFO = -6 - ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR. - $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN - INFO = -7 - ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN - INFO = -9 - ELSE IF( ITYPE.GE.4 ) THEN - IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN - INFO = -2 - ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR. - $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) ) - $ THEN - INFO = -3 - ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR. - $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR. - $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN - INFO = -9 - END IF - END IF -* - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASCL', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. M.EQ.0 ) - $ RETURN -* -* Get machine parameters -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM -* - CFROMC = CFROM - CTOC = CTO -* - 10 CONTINUE - CFROM1 = CFROMC*SMLNUM - CTO1 = CTOC / BIGNUM - IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN - MUL = SMLNUM - DONE = .FALSE. - CFROMC = CFROM1 - ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN - MUL = BIGNUM - DONE = .FALSE. - CTOC = CTO1 - ELSE - MUL = CTOC / CFROMC - DONE = .TRUE. - END IF -* - IF( ITYPE.EQ.0 ) THEN -* -* Full matrix -* - DO 30 J = 1, N - DO 20 I = 1, M - A( I, J ) = A( I, J )*MUL - 20 CONTINUE - 30 CONTINUE -* - ELSE IF( ITYPE.EQ.1 ) THEN -* -* Lower triangular matrix -* - DO 50 J = 1, N - DO 40 I = J, M - A( I, J ) = A( I, J )*MUL - 40 CONTINUE - 50 CONTINUE -* - ELSE IF( ITYPE.EQ.2 ) THEN -* -* Upper triangular matrix -* - DO 70 J = 1, N - DO 60 I = 1, MIN( J, M ) - A( I, J ) = A( I, J )*MUL - 60 CONTINUE - 70 CONTINUE -* - ELSE IF( ITYPE.EQ.3 ) THEN -* -* Upper Hessenberg matrix -* - DO 90 J = 1, N - DO 80 I = 1, MIN( J+1, M ) - A( I, J ) = A( I, J )*MUL - 80 CONTINUE - 90 CONTINUE -* - ELSE IF( ITYPE.EQ.4 ) THEN -* -* Lower half of a symmetric band matrix -* - K3 = KL + 1 - K4 = N + 1 - DO 110 J = 1, N - DO 100 I = 1, MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 100 CONTINUE - 110 CONTINUE -* - ELSE IF( ITYPE.EQ.5 ) THEN -* -* Upper half of a symmetric band matrix -* - K1 = KU + 2 - K3 = KU + 1 - DO 130 J = 1, N - DO 120 I = MAX( K1-J, 1 ), K3 - A( I, J ) = A( I, J )*MUL - 120 CONTINUE - 130 CONTINUE -* - ELSE IF( ITYPE.EQ.6 ) THEN -* -* Band matrix -* - K1 = KL + KU + 2 - K2 = KL + 1 - K3 = 2*KL + KU + 1 - K4 = KL + KU + 1 + M - DO 150 J = 1, N - DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J ) - A( I, J ) = A( I, J )*MUL - 140 CONTINUE - 150 CONTINUE -* - END IF -* - IF( .NOT.DONE ) - $ GO TO 10 -* - RETURN -* -* End of DLASCL -* - END diff --git a/ext/lapack/dlaset.f b/ext/lapack/dlaset.f deleted file mode 100644 index c086b6159..000000000 --- a/ext/lapack/dlaset.f +++ /dev/null @@ -1,115 +0,0 @@ - SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER LDA, M, N - DOUBLE PRECISION ALPHA, BETA -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASET initializes an m-by-n matrix A to BETA on the diagonal and -* ALPHA on the offdiagonals. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies the part of the matrix A to be set. -* = 'U': Upper triangular part is set; the strictly lower -* triangular part of A is not changed. -* = 'L': Lower triangular part is set; the strictly upper -* triangular part of A is not changed. -* Otherwise: All of the matrix A is set. -* -* M (input) INTEGER -* The number of rows of the matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix A. N >= 0. -* -* ALPHA (input) DOUBLE PRECISION -* The constant to which the offdiagonal elements are to be set. -* -* BETA (input) DOUBLE PRECISION -* The constant to which the diagonal elements are to be set. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On exit, the leading m-by-n submatrix of A is set as follows: -* -* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, -* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, -* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, -* -* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. -* - IF( LSAME( UPLO, 'U' ) ) THEN -* -* Set the strictly upper triangular or trapezoidal part of the -* array to ALPHA. -* - DO 20 J = 2, N - DO 10 I = 1, MIN( J-1, M ) - A( I, J ) = ALPHA - 10 CONTINUE - 20 CONTINUE -* - ELSE IF( LSAME( UPLO, 'L' ) ) THEN -* -* Set the strictly lower triangular or trapezoidal part of the -* array to ALPHA. -* - DO 40 J = 1, MIN( M, N ) - DO 30 I = J + 1, M - A( I, J ) = ALPHA - 30 CONTINUE - 40 CONTINUE -* - ELSE -* -* Set the leading m-by-n submatrix to ALPHA. -* - DO 60 J = 1, N - DO 50 I = 1, M - A( I, J ) = ALPHA - 50 CONTINUE - 60 CONTINUE - END IF -* -* Set the first min(M,N) diagonal elements to BETA. -* - DO 70 I = 1, MIN( M, N ) - A( I, I ) = BETA - 70 CONTINUE -* - RETURN -* -* End of DLASET -* - END diff --git a/ext/lapack/dlasq1.f b/ext/lapack/dlasq1.f deleted file mode 100644 index 5614aabc7..000000000 --- a/ext/lapack/dlasq1.f +++ /dev/null @@ -1,222 +0,0 @@ - SUBROUTINE DLASQ1( N, D, E, WORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ), E( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DLASQ1 computes the singular values of a real N-by-N bidiagonal -* matrix with diagonal D and off-diagonal E. The singular values are -* computed to high relative accuracy, barring over/underflow or -* denormalization. The algorithm is described in -* -* "Accurate singular values and differential qd algorithms," by -* K. V. Fernando and B. N. Parlett, -* Numer. Math., Vol-67, No. 2, pp. 191-230,1994. -* -* See also -* "Implementation of differential qd algorithms," by -* K. V. Fernando and B. N. Parlett, Technical Report, -* Department of Mathematics, University of California at Berkeley, -* 1994 (Under preparation). -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of rows and columns in the matrix. N >= 0. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, D contains the diagonal elements of the -* bidiagonal matrix whose SVD is desired. On normal exit, -* D contains the singular values in decreasing order. -* -* E (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, elements E(1:N-1) contain the off-diagonal elements -* of the bidiagonal matrix whose SVD is desired. -* On exit, E is overwritten. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (2*N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the algorithm did not converge; i -* specifies how many superdiagonals did not converge. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION MEIGTH - PARAMETER ( MEIGTH = -0.125D0 ) - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TEN - PARAMETER ( TEN = 10.0D0 ) - DOUBLE PRECISION HUNDRD - PARAMETER ( HUNDRD = 100.0D0 ) - DOUBLE PRECISION TWO56 - PARAMETER ( TWO56 = 256.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL RESTRT - INTEGER I, IERR, J, KE, KEND, M, NY - DOUBLE PRECISION DM, DX, EPS, SCL, SFMIN, SIG1, SIG2, SIGMN, - $ SIGMX, SMALL2, THRESH, TOL, TOL2, TOLMUL -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX, MIN, SQRT -* .. -* .. Executable Statements .. - INFO = 0 - IF( N.LT.0 ) THEN - INFO = -2 - CALL XERBLA( 'DLASQ1', -INFO ) - RETURN - ELSE IF( N.EQ.0 ) THEN - RETURN - ELSE IF( N.EQ.1 ) THEN - D( 1 ) = ABS( D( 1 ) ) - RETURN - ELSE IF( N.EQ.2 ) THEN - CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX ) - D( 1 ) = SIGMX - D( 2 ) = SIGMN - RETURN - END IF -* -* Estimate the largest singular value -* - SIGMX = ZERO - DO 10 I = 1, N - 1 - SIGMX = MAX( SIGMX, ABS( E( I ) ) ) - 10 CONTINUE -* -* Early return if sigmx is zero (matrix is already diagonal) -* - IF( SIGMX.EQ.ZERO ) - $ GO TO 70 -* - DO 20 I = 1, N - D( I ) = ABS( D( I ) ) - SIGMX = MAX( SIGMX, D( I ) ) - 20 CONTINUE -* -* Get machine parameters -* - EPS = DLAMCH( 'EPSILON' ) - SFMIN = DLAMCH( 'SAFE MINIMUM' ) -* -* Compute singular values to relative accuracy TOL -* It is assumed that tol**2 does not underflow. -* - TOLMUL = MAX( TEN, MIN( HUNDRD, EPS**( -MEIGTH ) ) ) - TOL = TOLMUL*EPS - TOL2 = TOL**2 -* - THRESH = SIGMX*SQRT( SFMIN )*TOL -* -* Scale matrix so the square of the largest element is -* 1 / ( 256 * SFMIN ) -* - SCL = SQRT( ONE / ( TWO56*SFMIN ) ) - SMALL2 = ONE / ( TWO56*TOLMUL**2 ) - CALL DCOPY( N, D, 1, WORK( 1 ), 1 ) - CALL DCOPY( N-1, E, 1, WORK( N+1 ), 1 ) - CALL DLASCL( 'G', 0, 0, SIGMX, SCL, N, 1, WORK( 1 ), N, IERR ) - CALL DLASCL( 'G', 0, 0, SIGMX, SCL, N-1, 1, WORK( N+1 ), N-1, - $ IERR ) -* -* Square D and E (the input for the qd algorithm) -* - DO 30 J = 1, 2*N - 1 - WORK( J ) = WORK( J )**2 - 30 CONTINUE -* -* Apply qd algorithm -* - M = 0 - E( N ) = ZERO - DX = WORK( 1 ) - DM = DX - KE = 0 - RESTRT = .FALSE. - DO 60 I = 1, N - IF( ABS( E( I ) ).LE.THRESH .OR. WORK( N+I ).LE.TOL2* - $ ( DM / DBLE( I-M ) ) ) THEN - NY = I - M - IF( NY.EQ.1 ) THEN - GO TO 50 - ELSE IF( NY.EQ.2 ) THEN - CALL DLAS2( D( M+1 ), E( M+1 ), D( M+2 ), SIG1, SIG2 ) - D( M+1 ) = SIG1 - D( M+2 ) = SIG2 - ELSE - KEND = KE + 1 - M - CALL DLASQ2( NY, D( M+1 ), E( M+1 ), WORK( M+1 ), - $ WORK( M+N+1 ), EPS, TOL2, SMALL2, DM, KEND, - $ INFO ) -* -* Return, INFO = number of unconverged superdiagonals -* - IF( INFO.NE.0 ) THEN - INFO = INFO + I - RETURN - END IF -* -* Undo scaling -* - DO 40 J = M + 1, M + NY - D( J ) = SQRT( D( J ) ) - 40 CONTINUE - CALL DLASCL( 'G', 0, 0, SCL, SIGMX, NY, 1, D( M+1 ), NY, - $ IERR ) - END IF - 50 CONTINUE - M = I - IF( I.NE.N ) THEN - DX = WORK( I+1 ) - DM = DX - KE = I - RESTRT = .TRUE. - END IF - END IF - IF( I.NE.N .AND. .NOT.RESTRT ) THEN - DX = WORK( I+1 )*( DX / ( DX+WORK( N+I ) ) ) - IF( DM.GT.DX ) THEN - DM = DX - KE = I - END IF - END IF - RESTRT = .FALSE. - 60 CONTINUE - KEND = KE + 1 -* -* Sort the singular values into decreasing order -* - 70 CONTINUE - CALL DLASRT( 'D', N, D, INFO ) - RETURN -* -* End of DLASQ1 -* - END diff --git a/ext/lapack/dlasq2.f b/ext/lapack/dlasq2.f deleted file mode 100644 index 14112a673..000000000 --- a/ext/lapack/dlasq2.f +++ /dev/null @@ -1,268 +0,0 @@ - SUBROUTINE DLASQ2( M, Q, E, QQ, EE, EPS, TOL2, SMALL2, SUP, KEND, - $ INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, KEND, M - DOUBLE PRECISION EPS, SMALL2, SUP, TOL2 -* .. -* .. Array Arguments .. - DOUBLE PRECISION E( * ), EE( * ), Q( * ), QQ( * ) -* .. -* -* Purpose -* ======= -* -* DLASQ2 computes the singular values of a real N-by-N unreduced -* bidiagonal matrix with squared diagonal elements in Q and -* squared off-diagonal elements in E. The singular values are -* computed to relative accuracy TOL, barring over/underflow or -* denormalization. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows and columns in the matrix. M >= 0. -* -* Q (output) DOUBLE PRECISION array, dimension (M) -* On normal exit, contains the squared singular values. -* -* E (workspace) DOUBLE PRECISION array, dimension (M) -* -* QQ (input/output) DOUBLE PRECISION array, dimension (M) -* On entry, QQ contains the squared diagonal elements of the -* bidiagonal matrix whose SVD is desired. -* On exit, QQ is overwritten. -* -* EE (input/output) DOUBLE PRECISION array, dimension (M) -* On entry, EE(1:N-1) contains the squared off-diagonal -* elements of the bidiagonal matrix whose SVD is desired. -* On exit, EE is overwritten. -* -* EPS (input) DOUBLE PRECISION -* Machine epsilon. -* -* TOL2 (input) DOUBLE PRECISION -* Desired relative accuracy of computed eigenvalues -* as defined in DLASQ1. -* -* SMALL2 (input) DOUBLE PRECISION -* A threshold value as defined in DLASQ1. -* -* SUP (input/output) DOUBLE PRECISION -* Upper bound for the smallest eigenvalue. -* -* KEND (input/output) INTEGER -* Index where minimum d occurs. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the algorithm did not converge; i -* specifies how many superdiagonals did not converge. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) - DOUBLE PRECISION FOUR, HALF - PARAMETER ( FOUR = 4.0D+0, HALF = 0.5D+0 ) -* .. -* .. Local Scalars .. - INTEGER ICONV, IPHASE, ISP, N, OFF, OFF1 - DOUBLE PRECISION QEMAX, SIGMA, XINF, XX, YY -* .. -* .. External Subroutines .. - EXTERNAL DLASQ3 -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN, NINT, SQRT -* .. -* .. Executable Statements .. - N = M -* -* Set the default maximum number of iterations -* - OFF = 0 - OFF1 = OFF + 1 - SIGMA = ZERO - XINF = ZERO - ICONV = 0 - IPHASE = 2 -* -* Try deflation at the bottom -* -* 1x1 deflation -* - 10 CONTINUE - IF( N.LE.2 ) - $ GO TO 20 - IF( EE( N-1 ).LE.MAX( QQ( N ), XINF, SMALL2 )*TOL2 ) THEN - Q( N ) = QQ( N ) - N = N - 1 - IF( KEND.GT.N ) - $ KEND = N - SUP = MIN( QQ( N ), QQ( N-1 ) ) - GO TO 10 - END IF -* -* 2x2 deflation -* - IF( EE( N-2 ).LE.MAX( XINF, SMALL2, - $ ( QQ( N ) / ( QQ( N )+EE( N-1 )+QQ( N-1 ) ) )*QQ( N-1 ) )* - $ TOL2 ) THEN - QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) ) - IF( QEMAX.NE.ZERO ) THEN - IF( QEMAX.EQ.QQ( N-1 ) ) THEN - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) ) - ELSE IF( QEMAX.EQ.QQ( N ) ) THEN - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N-1 )-QQ( N )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) ) - ELSE - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*QQ( N-1 ) / QEMAX ) ) - END IF - YY = ( MAX( QQ( N ), QQ( N-1 ) ) / XX )* - $ MIN( QQ( N ), QQ( N-1 ) ) - ELSE - XX = ZERO - YY = ZERO - END IF - Q( N-1 ) = XX - Q( N ) = YY - N = N - 2 - IF( KEND.GT.N ) - $ KEND = N - SUP = QQ( N ) - GO TO 10 - END IF -* - 20 CONTINUE - IF( N.EQ.0 ) THEN -* -* The lower branch is finished -* - IF( OFF.EQ.0 ) THEN -* -* No upper branch; return to DLASQ1 -* - RETURN - ELSE -* -* Going back to upper branch -* - XINF = ZERO - IF( EE( OFF ).GT.ZERO ) THEN - ISP = NINT( EE( OFF ) ) - IPHASE = 1 - ELSE - ISP = -NINT( EE( OFF ) ) - IPHASE = 2 - END IF - SIGMA = E( OFF ) - N = OFF - ISP + 1 - OFF1 = ISP - OFF = OFF1 - 1 - IF( N.LE.2 ) - $ GO TO 20 - IF( IPHASE.EQ.1 ) THEN - SUP = MIN( Q( N+OFF ), Q( N-1+OFF ), Q( N-2+OFF ) ) - ELSE - SUP = MIN( QQ( N+OFF ), QQ( N-1+OFF ), QQ( N-2+OFF ) ) - END IF - KEND = 0 - ICONV = -3 - END IF - ELSE IF( N.EQ.1 ) THEN -* -* 1x1 Solver -* - IF( IPHASE.EQ.1 ) THEN - Q( OFF1 ) = Q( OFF1 ) + SIGMA - ELSE - Q( OFF1 ) = QQ( OFF1 ) + SIGMA - END IF - N = 0 - GO TO 20 -* -* 2x2 Solver -* - ELSE IF( N.EQ.2 ) THEN - IF( IPHASE.EQ.2 ) THEN - QEMAX = MAX( QQ( N+OFF ), QQ( N-1+OFF ), EE( N-1+OFF ) ) - IF( QEMAX.NE.ZERO ) THEN - IF( QEMAX.EQ.QQ( N-1+OFF ) ) THEN - XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+ - $ QEMAX*SQRT( ( ( QQ( N+OFF )-QQ( N-1+OFF )+EE( N- - $ 1+OFF ) ) / QEMAX )**2+FOUR*EE( OFF+N-1 ) / - $ QEMAX ) ) - ELSE IF( QEMAX.EQ.QQ( N+OFF ) ) THEN - XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+ - $ QEMAX*SQRT( ( ( QQ( N-1+OFF )-QQ( N+OFF )+EE( N- - $ 1+OFF ) ) / QEMAX )**2+FOUR*EE( N-1+OFF ) / - $ QEMAX ) ) - ELSE - XX = HALF*( QQ( N+OFF )+QQ( N-1+OFF )+EE( N-1+OFF )+ - $ QEMAX*SQRT( ( ( QQ( N+OFF )-QQ( N-1+OFF )+EE( N- - $ 1+OFF ) ) / QEMAX )**2+FOUR*QQ( N-1+OFF ) / - $ QEMAX ) ) - END IF - YY = ( MAX( QQ( N+OFF ), QQ( N-1+OFF ) ) / XX )* - $ MIN( QQ( N+OFF ), QQ( N-1+OFF ) ) - ELSE - XX = ZERO - YY = ZERO - END IF - ELSE - QEMAX = MAX( Q( N+OFF ), Q( N-1+OFF ), E( N-1+OFF ) ) - IF( QEMAX.NE.ZERO ) THEN - IF( QEMAX.EQ.Q( N-1+OFF ) ) THEN - XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+ - $ QEMAX*SQRT( ( ( Q( N+OFF )-Q( N-1+OFF )+E( N-1+ - $ OFF ) ) / QEMAX )**2+FOUR*E( N-1+OFF ) / - $ QEMAX ) ) - ELSE IF( QEMAX.EQ.Q( N+OFF ) ) THEN - XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+ - $ QEMAX*SQRT( ( ( Q( N-1+OFF )-Q( N+OFF )+E( N-1+ - $ OFF ) ) / QEMAX )**2+FOUR*E( N-1+OFF ) / - $ QEMAX ) ) - ELSE - XX = HALF*( Q( N+OFF )+Q( N-1+OFF )+E( N-1+OFF )+ - $ QEMAX*SQRT( ( ( Q( N+OFF )-Q( N-1+OFF )+E( N-1+ - $ OFF ) ) / QEMAX )**2+FOUR*Q( N-1+OFF ) / - $ QEMAX ) ) - END IF - YY = ( MAX( Q( N+OFF ), Q( N-1+OFF ) ) / XX )* - $ MIN( Q( N+OFF ), Q( N-1+OFF ) ) - ELSE - XX = ZERO - YY = ZERO - END IF - END IF - Q( N-1+OFF ) = SIGMA + XX - Q( N+OFF ) = YY + SIGMA - N = 0 - GO TO 20 - END IF - CALL DLASQ3( N, Q( OFF1 ), E( OFF1 ), QQ( OFF1 ), EE( OFF1 ), SUP, - $ SIGMA, KEND, OFF, IPHASE, ICONV, EPS, TOL2, SMALL2 ) - IF( SUP.LT.ZERO ) THEN - INFO = N + OFF - RETURN - END IF - OFF1 = OFF + 1 - GO TO 20 -* -* End of DLASQ2 -* - END diff --git a/ext/lapack/dlasq3.f b/ext/lapack/dlasq3.f deleted file mode 100644 index 03daaaf4c..000000000 --- a/ext/lapack/dlasq3.f +++ /dev/null @@ -1,820 +0,0 @@ - SUBROUTINE DLASQ3( N, Q, E, QQ, EE, SUP, SIGMA, KEND, OFF, IPHASE, - $ ICONV, EPS, TOL2, SMALL2 ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER ICONV, IPHASE, KEND, N, OFF - DOUBLE PRECISION EPS, SIGMA, SMALL2, SUP, TOL2 -* .. -* .. Array Arguments .. - DOUBLE PRECISION E( * ), EE( * ), Q( * ), QQ( * ) -* .. -* -* Purpose -* ======= -* -* DLASQ3 is the workhorse of the whole bidiagonal SVD algorithm. -* This can be described as the differential qd with shifts. -* -* Arguments -* ========= -* -* N (input/output) INTEGER -* On entry, N specifies the number of rows and columns -* in the matrix. N must be at least 3. -* On exit N is non-negative and less than the input value. -* -* Q (input/output) DOUBLE PRECISION array, dimension (N) -* Q array in ping (see IPHASE below) -* -* E (input/output) DOUBLE PRECISION array, dimension (N) -* E array in ping (see IPHASE below) -* -* QQ (input/output) DOUBLE PRECISION array, dimension (N) -* Q array in pong (see IPHASE below) -* -* EE (input/output) DOUBLE PRECISION array, dimension (N) -* E array in pong (see IPHASE below) -* -* SUP (input/output) DOUBLE PRECISION -* Upper bound for the smallest eigenvalue -* -* SIGMA (input/output) DOUBLE PRECISION -* Accumulated shift for the present submatrix -* -* KEND (input/output) INTEGER -* Index where minimum D(i) occurs in recurrence for -* splitting criterion -* -* OFF (input/output) INTEGER -* Offset for arrays -* -* IPHASE (input/output) INTEGER -* If IPHASE = 1 (ping) then data is in Q and E arrays -* If IPHASE = 2 (pong) then data is in QQ and EE arrays -* -* ICONV (input) INTEGER -* If ICONV = 0 a bottom part of a matrix (with a split) -* If ICONV =-3 a top part of a matrix (with a split) -* -* EPS (input) DOUBLE PRECISION -* Machine epsilon -* -* TOL2 (input) DOUBLE PRECISION -* Square of the relative tolerance TOL as defined in DLASQ1 -* -* SMALL2 (input) DOUBLE PRECISION -* A threshold value as defined in DLASQ1 -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) - INTEGER NPP - PARAMETER ( NPP = 32 ) - INTEGER IPP - PARAMETER ( IPP = 5 ) - DOUBLE PRECISION HALF, FOUR - PARAMETER ( HALF = 0.5D+0, FOUR = 4.0D+0 ) - INTEGER IFLMAX - PARAMETER ( IFLMAX = 2 ) -* .. -* .. Local Scalars .. - LOGICAL LDEF, LSPLIT - INTEGER I, IC, ICNT, IFL, IP, ISP, K1END, K2END, KE, - $ KS, MAXIT, N1, N2 - DOUBLE PRECISION D, DM, QEMAX, T1, TAU, TOLX, TOLY, TOLZ, XX, YY -* .. -* .. External Subroutines .. - EXTERNAL DCOPY, DLASQ4 -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN, SQRT -* .. -* .. Executable Statements .. - ICNT = 0 - TAU = ZERO - DM = SUP - TOLX = SIGMA*TOL2 - TOLZ = MAX( SMALL2, SIGMA )*TOL2 -* -* Set maximum number of iterations -* - MAXIT = 100*N -* -* Flipping -* - IC = 2 - IF( N.GT.3 ) THEN - IF( IPHASE.EQ.1 ) THEN - DO 10 I = 1, N - 2 - IF( Q( I ).GT.Q( I+1 ) ) - $ IC = IC + 1 - IF( E( I ).GT.E( I+1 ) ) - $ IC = IC + 1 - 10 CONTINUE - IF( Q( N-1 ).GT.Q( N ) ) - $ IC = IC + 1 - IF( IC.LT.N ) THEN - CALL DCOPY( N, Q, 1, QQ, -1 ) - CALL DCOPY( N-1, E, 1, EE, -1 ) - IF( KEND.NE.0 ) - $ KEND = N - KEND + 1 - IPHASE = 2 - END IF - ELSE - DO 20 I = 1, N - 2 - IF( QQ( I ).GT.QQ( I+1 ) ) - $ IC = IC + 1 - IF( EE( I ).GT.EE( I+1 ) ) - $ IC = IC + 1 - 20 CONTINUE - IF( QQ( N-1 ).GT.QQ( N ) ) - $ IC = IC + 1 - IF( IC.LT.N ) THEN - CALL DCOPY( N, QQ, 1, Q, -1 ) - CALL DCOPY( N-1, EE, 1, E, -1 ) - IF( KEND.NE.0 ) - $ KEND = N - KEND + 1 - IPHASE = 1 - END IF - END IF - END IF - IF( ICONV.EQ.-3 ) THEN - IF( IPHASE.EQ.1 ) THEN - GO TO 180 - ELSE - GO TO 80 - END IF - END IF - IF( IPHASE.EQ.2 ) - $ GO TO 130 -* -* The ping section of the code -* - 30 CONTINUE - IFL = 0 -* -* Compute the shift -* - IF( KEND.EQ.0 .OR. SUP.EQ.ZERO ) THEN - TAU = ZERO - ELSE IF( ICNT.GT.0 .AND. DM.LE.TOLZ ) THEN - TAU = ZERO - ELSE - IP = MAX( IPP, N / NPP ) - N2 = 2*IP + 1 - IF( N2.GE.N ) THEN - N1 = 1 - N2 = N - ELSE IF( KEND+IP.GT.N ) THEN - N1 = N - 2*IP - ELSE IF( KEND-IP.LT.1 ) THEN - N1 = 1 - ELSE - N1 = KEND - IP - END IF - CALL DLASQ4( N2, Q( N1 ), E( N1 ), TAU, SUP ) - END IF - 40 CONTINUE - ICNT = ICNT + 1 - IF( ICNT.GT.MAXIT ) THEN - SUP = -ONE - RETURN - END IF - IF( TAU.EQ.ZERO ) THEN -* -* dqd algorithm -* - D = Q( 1 ) - DM = D - KE = 0 - DO 50 I = 1, N - 3 - QQ( I ) = D + E( I ) - D = ( D / QQ( I ) )*Q( I+1 ) - IF( DM.GT.D ) THEN - DM = D - KE = I - END IF - 50 CONTINUE - KE = KE + 1 -* -* Penultimate dqd step (in ping) -* - K2END = KE - QQ( N-2 ) = D + E( N-2 ) - D = ( D / QQ( N-2 ) )*Q( N-1 ) - IF( DM.GT.D ) THEN - DM = D - KE = N - 1 - END IF -* -* Final dqd step (in ping) -* - K1END = KE - QQ( N-1 ) = D + E( N-1 ) - D = ( D / QQ( N-1 ) )*Q( N ) - IF( DM.GT.D ) THEN - DM = D - KE = N - END IF - QQ( N ) = D - ELSE -* -* The dqds algorithm (in ping) -* - D = Q( 1 ) - TAU - DM = D - KE = 0 - IF( D.LT.ZERO ) - $ GO TO 120 - DO 60 I = 1, N - 3 - QQ( I ) = D + E( I ) - D = ( D / QQ( I ) )*Q( I+1 ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = I - IF( D.LT.ZERO ) - $ GO TO 120 - END IF - 60 CONTINUE - KE = KE + 1 -* -* Penultimate dqds step (in ping) -* - K2END = KE - QQ( N-2 ) = D + E( N-2 ) - D = ( D / QQ( N-2 ) )*Q( N-1 ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = N - 1 - IF( D.LT.ZERO ) - $ GO TO 120 - END IF -* -* Final dqds step (in ping) -* - K1END = KE - QQ( N-1 ) = D + E( N-1 ) - D = ( D / QQ( N-1 ) )*Q( N ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = N - END IF - QQ( N ) = D - END IF -* -* Convergence when QQ(N) is small (in ping) -* - IF( ABS( QQ( N ) ).LE.SIGMA*TOL2 ) THEN - QQ( N ) = ZERO - DM = ZERO - KE = N - END IF - IF( QQ( N ).LT.ZERO ) - $ GO TO 120 -* -* Non-negative qd array: Update the e's -* - DO 70 I = 1, N - 1 - EE( I ) = ( E( I ) / QQ( I ) )*Q( I+1 ) - 70 CONTINUE -* -* Updating sigma and iphase in ping -* - SIGMA = SIGMA + TAU - IPHASE = 2 - 80 CONTINUE - TOLX = SIGMA*TOL2 - TOLY = SIGMA*EPS - TOLZ = MAX( SIGMA, SMALL2 )*TOL2 -* -* Checking for deflation and convergence (in ping) -* - 90 CONTINUE - IF( N.LE.2 ) - $ RETURN -* -* Deflation: bottom 1x1 (in ping) -* - LDEF = .FALSE. - IF( EE( N-1 ).LE.TOLZ ) THEN - LDEF = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - IF( EE( N-1 ).LE.EPS*( SIGMA+QQ( N ) ) ) THEN - IF( EE( N-1 )*( QQ( N ) / ( QQ( N )+SIGMA ) ).LE.TOL2* - $ ( QQ( N )+SIGMA ) ) THEN - LDEF = .TRUE. - END IF - END IF - ELSE - IF( EE( N-1 ).LE.QQ( N )*TOL2 ) THEN - LDEF = .TRUE. - END IF - END IF - IF( LDEF ) THEN - Q( N ) = QQ( N ) + SIGMA - N = N - 1 - ICONV = ICONV + 1 - GO TO 90 - END IF -* -* Deflation: bottom 2x2 (in ping) -* - LDEF = .FALSE. - IF( EE( N-2 ).LE.TOLZ ) THEN - LDEF = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - T1 = SIGMA + EE( N-1 )*( SIGMA / ( SIGMA+QQ( N ) ) ) - IF( EE( N-2 )*( T1 / ( QQ( N-1 )+T1 ) ).LE.TOLY ) THEN - IF( EE( N-2 )*( QQ( N-1 ) / ( QQ( N-1 )+T1 ) ).LE.TOLX ) - $ THEN - LDEF = .TRUE. - END IF - END IF - ELSE - IF( EE( N-2 ).LE.( QQ( N ) / ( QQ( N )+EE( N-1 )+QQ( N-1 ) ) )* - $ QQ( N-1 )*TOL2 ) THEN - LDEF = .TRUE. - END IF - END IF - IF( LDEF ) THEN - QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) ) - IF( QEMAX.NE.ZERO ) THEN - IF( QEMAX.EQ.QQ( N-1 ) ) THEN - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) ) - ELSE IF( QEMAX.EQ.QQ( N ) ) THEN - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N-1 )-QQ( N )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*EE( N-1 ) / QEMAX ) ) - ELSE - XX = HALF*( QQ( N )+QQ( N-1 )+EE( N-1 )+QEMAX* - $ SQRT( ( ( QQ( N )-QQ( N-1 )+EE( N-1 ) ) / - $ QEMAX )**2+FOUR*QQ( N-1 ) / QEMAX ) ) - END IF - YY = ( MAX( QQ( N ), QQ( N-1 ) ) / XX )* - $ MIN( QQ( N ), QQ( N-1 ) ) - ELSE - XX = ZERO - YY = ZERO - END IF - Q( N-1 ) = SIGMA + XX - Q( N ) = YY + SIGMA - N = N - 2 - ICONV = ICONV + 2 - GO TO 90 - END IF -* -* Updating bounds before going to pong -* - IF( ICONV.EQ.0 ) THEN - KEND = KE - SUP = MIN( DM, SUP-TAU ) - ELSE IF( ICONV.GT.0 ) THEN - SUP = MIN( QQ( N ), QQ( N-1 ), QQ( N-2 ), QQ( 1 ), QQ( 2 ), - $ QQ( 3 ) ) - IF( ICONV.EQ.1 ) THEN - KEND = K1END - ELSE IF( ICONV.EQ.2 ) THEN - KEND = K2END - ELSE - KEND = N - END IF - ICNT = 0 - MAXIT = 100*N - END IF -* -* Checking for splitting in ping -* - LSPLIT = .FALSE. - DO 100 KS = N - 3, 3, -1 - IF( EE( KS ).LE.TOLY ) THEN - IF( EE( KS )*( MIN( QQ( KS+1 ), - $ QQ( KS ) ) / ( MIN( QQ( KS+1 ), QQ( KS ) )+SIGMA ) ).LE. - $ TOLX ) THEN - LSPLIT = .TRUE. - GO TO 110 - END IF - END IF - 100 CONTINUE -* - KS = 2 - IF( EE( 2 ).LE.TOLZ ) THEN - LSPLIT = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - T1 = SIGMA + EE( 1 )*( SIGMA / ( SIGMA+QQ( 1 ) ) ) - IF( EE( 2 )*( T1 / ( QQ( 1 )+T1 ) ).LE.TOLY ) THEN - IF( EE( 2 )*( QQ( 1 ) / ( QQ( 1 )+T1 ) ).LE.TOLX ) THEN - LSPLIT = .TRUE. - END IF - END IF - ELSE - IF( EE( 2 ).LE.( QQ( 1 ) / ( QQ( 1 )+EE( 1 )+QQ( 2 ) ) )* - $ QQ( 2 )*TOL2 ) THEN - LSPLIT = .TRUE. - END IF - END IF - IF( LSPLIT ) - $ GO TO 110 -* - KS = 1 - IF( EE( 1 ).LE.TOLZ ) THEN - LSPLIT = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - IF( EE( 1 ).LE.EPS*( SIGMA+QQ( 1 ) ) ) THEN - IF( EE( 1 )*( QQ( 1 ) / ( QQ( 1 )+SIGMA ) ).LE.TOL2* - $ ( QQ( 1 )+SIGMA ) ) THEN - LSPLIT = .TRUE. - END IF - END IF - ELSE - IF( EE( 1 ).LE.QQ( 1 )*TOL2 ) THEN - LSPLIT = .TRUE. - END IF - END IF -* - 110 CONTINUE - IF( LSPLIT ) THEN - SUP = MIN( QQ( N ), QQ( N-1 ), QQ( N-2 ) ) - ISP = -( OFF+1 ) - OFF = OFF + KS - N = N - KS - KEND = MAX( 1, KEND-KS ) - E( KS ) = SIGMA - EE( KS ) = ISP - ICONV = 0 - RETURN - END IF -* -* Coincidence -* - IF( TAU.EQ.ZERO .AND. DM.LE.TOLZ .AND. KEND.NE.N .AND. ICONV.EQ. - $ 0 .AND. ICNT.GT.0 ) THEN - CALL DCOPY( N-KE, E( KE ), 1, QQ( KE ), 1 ) - QQ( N ) = ZERO - CALL DCOPY( N-KE, Q( KE+1 ), 1, EE( KE ), 1 ) - SUP = ZERO - END IF - ICONV = 0 - GO TO 130 -* -* A new shift when the previous failed (in ping) -* - 120 CONTINUE - IFL = IFL + 1 - SUP = TAU -* -* SUP is small or -* Too many bad shifts (ping) -* - IF( SUP.LE.TOLZ .OR. IFL.GE.IFLMAX ) THEN - TAU = ZERO - GO TO 40 -* -* The asymptotic shift (in ping) -* - ELSE - TAU = MAX( TAU+D, ZERO ) - IF( TAU.LE.TOLZ ) - $ TAU = ZERO - GO TO 40 - END IF -* -* the pong section of the code -* - 130 CONTINUE - IFL = 0 -* -* Compute the shift (in pong) -* - IF( KEND.EQ.0 .AND. SUP.EQ.ZERO ) THEN - TAU = ZERO - ELSE IF( ICNT.GT.0 .AND. DM.LE.TOLZ ) THEN - TAU = ZERO - ELSE - IP = MAX( IPP, N / NPP ) - N2 = 2*IP + 1 - IF( N2.GE.N ) THEN - N1 = 1 - N2 = N - ELSE IF( KEND+IP.GT.N ) THEN - N1 = N - 2*IP - ELSE IF( KEND-IP.LT.1 ) THEN - N1 = 1 - ELSE - N1 = KEND - IP - END IF - CALL DLASQ4( N2, QQ( N1 ), EE( N1 ), TAU, SUP ) - END IF - 140 CONTINUE - ICNT = ICNT + 1 - IF( ICNT.GT.MAXIT ) THEN - SUP = -SUP - RETURN - END IF - IF( TAU.EQ.ZERO ) THEN -* -* The dqd algorithm (in pong) -* - D = QQ( 1 ) - DM = D - KE = 0 - DO 150 I = 1, N - 3 - Q( I ) = D + EE( I ) - D = ( D / Q( I ) )*QQ( I+1 ) - IF( DM.GT.D ) THEN - DM = D - KE = I - END IF - 150 CONTINUE - KE = KE + 1 -* -* Penultimate dqd step (in pong) -* - K2END = KE - Q( N-2 ) = D + EE( N-2 ) - D = ( D / Q( N-2 ) )*QQ( N-1 ) - IF( DM.GT.D ) THEN - DM = D - KE = N - 1 - END IF -* -* Final dqd step (in pong) -* - K1END = KE - Q( N-1 ) = D + EE( N-1 ) - D = ( D / Q( N-1 ) )*QQ( N ) - IF( DM.GT.D ) THEN - DM = D - KE = N - END IF - Q( N ) = D - ELSE -* -* The dqds algorithm (in pong) -* - D = QQ( 1 ) - TAU - DM = D - KE = 0 - IF( D.LT.ZERO ) - $ GO TO 220 - DO 160 I = 1, N - 3 - Q( I ) = D + EE( I ) - D = ( D / Q( I ) )*QQ( I+1 ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = I - IF( D.LT.ZERO ) - $ GO TO 220 - END IF - 160 CONTINUE - KE = KE + 1 -* -* Penultimate dqds step (in pong) -* - K2END = KE - Q( N-2 ) = D + EE( N-2 ) - D = ( D / Q( N-2 ) )*QQ( N-1 ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = N - 1 - IF( D.LT.ZERO ) - $ GO TO 220 - END IF -* -* Final dqds step (in pong) -* - K1END = KE - Q( N-1 ) = D + EE( N-1 ) - D = ( D / Q( N-1 ) )*QQ( N ) - TAU - IF( DM.GT.D ) THEN - DM = D - KE = N - END IF - Q( N ) = D - END IF -* -* Convergence when is small (in pong) -* - IF( ABS( Q( N ) ).LE.SIGMA*TOL2 ) THEN - Q( N ) = ZERO - DM = ZERO - KE = N - END IF - IF( Q( N ).LT.ZERO ) - $ GO TO 220 -* -* Non-negative qd array: Update the e's -* - DO 170 I = 1, N - 1 - E( I ) = ( EE( I ) / Q( I ) )*QQ( I+1 ) - 170 CONTINUE -* -* Updating sigma and iphase in pong -* - SIGMA = SIGMA + TAU - 180 CONTINUE - IPHASE = 1 - TOLX = SIGMA*TOL2 - TOLY = SIGMA*EPS -* -* Checking for deflation and convergence (in pong) -* - 190 CONTINUE - IF( N.LE.2 ) - $ RETURN -* -* Deflation: bottom 1x1 (in pong) -* - LDEF = .FALSE. - IF( E( N-1 ).LE.TOLZ ) THEN - LDEF = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - IF( E( N-1 ).LE.EPS*( SIGMA+Q( N ) ) ) THEN - IF( E( N-1 )*( Q( N ) / ( Q( N )+SIGMA ) ).LE.TOL2* - $ ( Q( N )+SIGMA ) ) THEN - LDEF = .TRUE. - END IF - END IF - ELSE - IF( E( N-1 ).LE.Q( N )*TOL2 ) THEN - LDEF = .TRUE. - END IF - END IF - IF( LDEF ) THEN - Q( N ) = Q( N ) + SIGMA - N = N - 1 - ICONV = ICONV + 1 - GO TO 190 - END IF -* -* Deflation: bottom 2x2 (in pong) -* - LDEF = .FALSE. - IF( E( N-2 ).LE.TOLZ ) THEN - LDEF = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - T1 = SIGMA + E( N-1 )*( SIGMA / ( SIGMA+Q( N ) ) ) - IF( E( N-2 )*( T1 / ( Q( N-1 )+T1 ) ).LE.TOLY ) THEN - IF( E( N-2 )*( Q( N-1 ) / ( Q( N-1 )+T1 ) ).LE.TOLX ) THEN - LDEF = .TRUE. - END IF - END IF - ELSE - IF( E( N-2 ).LE.( Q( N ) / ( Q( N )+EE( N-1 )+Q( N-1 ) )*Q( N- - $ 1 ) )*TOL2 ) THEN - LDEF = .TRUE. - END IF - END IF - IF( LDEF ) THEN - QEMAX = MAX( Q( N ), Q( N-1 ), E( N-1 ) ) - IF( QEMAX.NE.ZERO ) THEN - IF( QEMAX.EQ.Q( N-1 ) ) THEN - XX = HALF*( Q( N )+Q( N-1 )+E( N-1 )+QEMAX* - $ SQRT( ( ( Q( N )-Q( N-1 )+E( N-1 ) ) / QEMAX )**2+ - $ FOUR*E( N-1 ) / QEMAX ) ) - ELSE IF( QEMAX.EQ.Q( N ) ) THEN - XX = HALF*( Q( N )+Q( N-1 )+E( N-1 )+QEMAX* - $ SQRT( ( ( Q( N-1 )-Q( N )+E( N-1 ) ) / QEMAX )**2+ - $ FOUR*E( N-1 ) / QEMAX ) ) - ELSE - XX = HALF*( Q( N )+Q( N-1 )+E( N-1 )+QEMAX* - $ SQRT( ( ( Q( N )-Q( N-1 )+E( N-1 ) ) / QEMAX )**2+ - $ FOUR*Q( N-1 ) / QEMAX ) ) - END IF - YY = ( MAX( Q( N ), Q( N-1 ) ) / XX )* - $ MIN( Q( N ), Q( N-1 ) ) - ELSE - XX = ZERO - YY = ZERO - END IF - Q( N-1 ) = SIGMA + XX - Q( N ) = YY + SIGMA - N = N - 2 - ICONV = ICONV + 2 - GO TO 190 - END IF -* -* Updating bounds before going to pong -* - IF( ICONV.EQ.0 ) THEN - KEND = KE - SUP = MIN( DM, SUP-TAU ) - ELSE IF( ICONV.GT.0 ) THEN - SUP = MIN( Q( N ), Q( N-1 ), Q( N-2 ), Q( 1 ), Q( 2 ), Q( 3 ) ) - IF( ICONV.EQ.1 ) THEN - KEND = K1END - ELSE IF( ICONV.EQ.2 ) THEN - KEND = K2END - ELSE - KEND = N - END IF - ICNT = 0 - MAXIT = 100*N - END IF -* -* Checking for splitting in pong -* - LSPLIT = .FALSE. - DO 200 KS = N - 3, 3, -1 - IF( E( KS ).LE.TOLY ) THEN - IF( E( KS )*( MIN( Q( KS+1 ), Q( KS ) ) / ( MIN( Q( KS+1 ), - $ Q( KS ) )+SIGMA ) ).LE.TOLX ) THEN - LSPLIT = .TRUE. - GO TO 210 - END IF - END IF - 200 CONTINUE -* - KS = 2 - IF( E( 2 ).LE.TOLZ ) THEN - LSPLIT = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - T1 = SIGMA + E( 1 )*( SIGMA / ( SIGMA+Q( 1 ) ) ) - IF( E( 2 )*( T1 / ( Q( 1 )+T1 ) ).LE.TOLY ) THEN - IF( E( 2 )*( Q( 1 ) / ( Q( 1 )+T1 ) ).LE.TOLX ) THEN - LSPLIT = .TRUE. - END IF - END IF - ELSE - IF( E( 2 ).LE.( Q( 1 ) / ( Q( 1 )+E( 1 )+Q( 2 ) ) )*Q( 2 )* - $ TOL2 ) THEN - LSPLIT = .TRUE. - END IF - END IF - IF( LSPLIT ) - $ GO TO 210 -* - KS = 1 - IF( E( 1 ).LE.TOLZ ) THEN - LSPLIT = .TRUE. - ELSE IF( SIGMA.GT.ZERO ) THEN - IF( E( 1 ).LE.EPS*( SIGMA+Q( 1 ) ) ) THEN - IF( E( 1 )*( Q( 1 ) / ( Q( 1 )+SIGMA ) ).LE.TOL2* - $ ( Q( 1 )+SIGMA ) ) THEN - LSPLIT = .TRUE. - END IF - END IF - ELSE - IF( E( 1 ).LE.Q( 1 )*TOL2 ) THEN - LSPLIT = .TRUE. - END IF - END IF -* - 210 CONTINUE - IF( LSPLIT ) THEN - SUP = MIN( Q( N ), Q( N-1 ), Q( N-2 ) ) - ISP = OFF + 1 - OFF = OFF + KS - KEND = MAX( 1, KEND-KS ) - N = N - KS - E( KS ) = SIGMA - EE( KS ) = ISP - ICONV = 0 - RETURN - END IF -* -* Coincidence -* - IF( TAU.EQ.ZERO .AND. DM.LE.TOLZ .AND. KEND.NE.N .AND. ICONV.EQ. - $ 0 .AND. ICNT.GT.0 ) THEN - CALL DCOPY( N-KE, EE( KE ), 1, Q( KE ), 1 ) - Q( N ) = ZERO - CALL DCOPY( N-KE, QQ( KE+1 ), 1, E( KE ), 1 ) - SUP = ZERO - END IF - ICONV = 0 - GO TO 30 -* -* Computation of a new shift when the previous failed (in pong) -* - 220 CONTINUE - IFL = IFL + 1 - SUP = TAU -* -* SUP is small or -* Too many bad shifts (in pong) -* - IF( SUP.LE.TOLZ .OR. IFL.GE.IFLMAX ) THEN - TAU = ZERO - GO TO 140 -* -* The asymptotic shift (in pong) -* - ELSE - TAU = MAX( TAU+D, ZERO ) - IF( TAU.LE.TOLZ ) - $ TAU = ZERO - GO TO 140 - END IF -* -* End of DLASQ3 -* - END diff --git a/ext/lapack/dlasq4.f b/ext/lapack/dlasq4.f deleted file mode 100644 index d410bae5d..000000000 --- a/ext/lapack/dlasq4.f +++ /dev/null @@ -1,103 +0,0 @@ - SUBROUTINE DLASQ4( N, Q, E, TAU, SUP ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER N - DOUBLE PRECISION SUP, TAU -* .. -* .. Array Arguments .. - DOUBLE PRECISION E( * ), Q( * ) -* .. -* -* Purpose -* ======= -* -* DLASQ4 estimates TAU, the smallest eigenvalue of a matrix. This -* routine improves the input value of SUP which is an upper bound -* for the smallest eigenvalue for this matrix . -* -* Arguments -* ========= -* -* N (input) INTEGER -* On entry, N specifies the number of rows and columns -* in the matrix. N must be at least 0. -* -* Q (input) DOUBLE PRECISION array, dimension (N) -* Q array -* -* E (input) DOUBLE PRECISION array, dimension (N) -* E array -* -* TAU (output) DOUBLE PRECISION -* Estimate of the shift -* -* SUP (input/output) DOUBLE PRECISION -* Upper bound for the smallest singular value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) - DOUBLE PRECISION BIS, BIS1 - PARAMETER ( BIS = 0.9999D+0, BIS1 = 0.7D+0 ) - INTEGER IFLMAX - PARAMETER ( IFLMAX = 5 ) -* .. -* .. Local Scalars .. - INTEGER I, IFL - DOUBLE PRECISION D, DM, XINF -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. - IFL = 1 - SUP = MIN( SUP, Q( 1 ), Q( 2 ), Q( 3 ), Q( N ), Q( N-1 ), - $ Q( N-2 ) ) - TAU = SUP*BIS - XINF = ZERO - 10 CONTINUE - IF( IFL.EQ.IFLMAX ) THEN - TAU = XINF - RETURN - END IF - D = Q( 1 ) - TAU - DM = D - DO 20 I = 1, N - 2 - D = ( D / ( D+E( I ) ) )*Q( I+1 ) - TAU - IF( DM.GT.D ) - $ DM = D - IF( D.LT.ZERO ) THEN - SUP = TAU - TAU = MAX( SUP*BIS1**IFL, D+TAU ) - IFL = IFL + 1 - GO TO 10 - END IF - 20 CONTINUE - D = ( D / ( D+E( N-1 ) ) )*Q( N ) - TAU - IF( DM.GT.D ) - $ DM = D - IF( D.LT.ZERO ) THEN - SUP = TAU - XINF = MAX( XINF, D+TAU ) - IF( SUP*BIS1**IFL.LE.XINF ) THEN - TAU = XINF - ELSE - TAU = SUP*BIS1**IFL - IFL = IFL + 1 - GO TO 10 - END IF - ELSE - SUP = MIN( SUP, DM+TAU ) - END IF - RETURN -* -* End of DLASQ4 -* - END diff --git a/ext/lapack/dlasr.f b/ext/lapack/dlasr.f deleted file mode 100644 index 9bf39ac70..000000000 --- a/ext/lapack/dlasr.f +++ /dev/null @@ -1,325 +0,0 @@ - SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIRECT, PIVOT, SIDE - INTEGER LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( * ), S( * ) -* .. -* -* Purpose -* ======= -* -* DLASR performs the transformation -* -* A := P*A, when SIDE = 'L' or 'l' ( Left-hand side ) -* -* A := A*P', when SIDE = 'R' or 'r' ( Right-hand side ) -* -* where A is an m by n real matrix and P is an orthogonal matrix, -* consisting of a sequence of plane rotations determined by the -* parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l' -* and z = n when SIDE = 'R' or 'r' ): -* -* When DIRECT = 'F' or 'f' ( Forward sequence ) then -* -* P = P( z - 1 )*...*P( 2 )*P( 1 ), -* -* and when DIRECT = 'B' or 'b' ( Backward sequence ) then -* -* P = P( 1 )*P( 2 )*...*P( z - 1 ), -* -* where P( k ) is a plane rotation matrix for the following planes: -* -* when PIVOT = 'V' or 'v' ( Variable pivot ), -* the plane ( k, k + 1 ) -* -* when PIVOT = 'T' or 't' ( Top pivot ), -* the plane ( 1, k + 1 ) -* -* when PIVOT = 'B' or 'b' ( Bottom pivot ), -* the plane ( k, z ) -* -* c( k ) and s( k ) must contain the cosine and sine that define the -* matrix P( k ). The two by two plane rotation part of the matrix -* P( k ), R( k ), is assumed to be of the form -* -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) -* -* This version vectorises across rows of the array A when SIDE = 'L'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* Specifies whether the plane rotation matrix P is applied to -* A on the left or the right. -* = 'L': Left, compute A := P*A -* = 'R': Right, compute A:= A*P' -* -* DIRECT (input) CHARACTER*1 -* Specifies whether P is a forward or backward sequence of -* plane rotations. -* = 'F': Forward, P = P( z - 1 )*...*P( 2 )*P( 1 ) -* = 'B': Backward, P = P( 1 )*P( 2 )*...*P( z - 1 ) -* -* PIVOT (input) CHARACTER*1 -* Specifies the plane for which P(k) is a plane rotation -* matrix. -* = 'V': Variable pivot, the plane (k,k+1) -* = 'T': Top pivot, the plane (1,k+1) -* = 'B': Bottom pivot, the plane (k,z) -* -* M (input) INTEGER -* The number of rows of the matrix A. If m <= 1, an immediate -* return is effected. -* -* N (input) INTEGER -* The number of columns of the matrix A. If n <= 1, an -* immediate return is effected. -* -* C, S (input) DOUBLE PRECISION arrays, dimension -* (M-1) if SIDE = 'L' -* (N-1) if SIDE = 'R' -* c(k) and s(k) contain the cosine and sine that define the -* matrix P(k). The two by two plane rotation part of the -* matrix P(k), R(k), is assumed to be of the form -* R( k ) = ( c( k ) s( k ) ). -* ( -s( k ) c( k ) ) -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* The m by n matrix A. On exit, A is overwritten by P*A if -* SIDE = 'R' or by A*P' if SIDE = 'L'. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, INFO, J - DOUBLE PRECISION CTEMP, STEMP, TEMP -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters -* - INFO = 0 - IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN - INFO = 1 - ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT, - $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN - INFO = 2 - ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) ) - $ THEN - INFO = 3 - ELSE IF( M.LT.0 ) THEN - INFO = 4 - ELSE IF( N.LT.0 ) THEN - INFO = 5 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = 9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASR ', INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) ) - $ RETURN - IF( LSAME( SIDE, 'L' ) ) THEN -* -* Form P * A -* - IF( LSAME( PIVOT, 'V' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 20 J = 1, M - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 10 I = 1, N - TEMP = A( J+1, I ) - A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) - A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) - 10 CONTINUE - END IF - 20 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 40 J = M - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 30 I = 1, N - TEMP = A( J+1, I ) - A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I ) - A( J, I ) = STEMP*TEMP + CTEMP*A( J, I ) - 30 CONTINUE - END IF - 40 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'T' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 60 J = 2, M - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 50 I = 1, N - TEMP = A( J, I ) - A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) - A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) - 50 CONTINUE - END IF - 60 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 80 J = M, 2, -1 - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 70 I = 1, N - TEMP = A( J, I ) - A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I ) - A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I ) - 70 CONTINUE - END IF - 80 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'B' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 100 J = 1, M - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 90 I = 1, N - TEMP = A( J, I ) - A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP - A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP - 90 CONTINUE - END IF - 100 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 120 J = M - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 110 I = 1, N - TEMP = A( J, I ) - A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP - A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP - 110 CONTINUE - END IF - 120 CONTINUE - END IF - END IF - ELSE IF( LSAME( SIDE, 'R' ) ) THEN -* -* Form A * P' -* - IF( LSAME( PIVOT, 'V' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 140 J = 1, N - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 130 I = 1, M - TEMP = A( I, J+1 ) - A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) - A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) - 130 CONTINUE - END IF - 140 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 160 J = N - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 150 I = 1, M - TEMP = A( I, J+1 ) - A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J ) - A( I, J ) = STEMP*TEMP + CTEMP*A( I, J ) - 150 CONTINUE - END IF - 160 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'T' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 180 J = 2, N - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 170 I = 1, M - TEMP = A( I, J ) - A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) - A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) - 170 CONTINUE - END IF - 180 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 200 J = N, 2, -1 - CTEMP = C( J-1 ) - STEMP = S( J-1 ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 190 I = 1, M - TEMP = A( I, J ) - A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 ) - A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 ) - 190 CONTINUE - END IF - 200 CONTINUE - END IF - ELSE IF( LSAME( PIVOT, 'B' ) ) THEN - IF( LSAME( DIRECT, 'F' ) ) THEN - DO 220 J = 1, N - 1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 210 I = 1, M - TEMP = A( I, J ) - A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP - A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP - 210 CONTINUE - END IF - 220 CONTINUE - ELSE IF( LSAME( DIRECT, 'B' ) ) THEN - DO 240 J = N - 1, 1, -1 - CTEMP = C( J ) - STEMP = S( J ) - IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN - DO 230 I = 1, M - TEMP = A( I, J ) - A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP - A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP - 230 CONTINUE - END IF - 240 CONTINUE - END IF - END IF - END IF -* - RETURN -* -* End of DLASR -* - END diff --git a/ext/lapack/dlasrt.f b/ext/lapack/dlasrt.f deleted file mode 100644 index 7b22eb3f1..000000000 --- a/ext/lapack/dlasrt.f +++ /dev/null @@ -1,244 +0,0 @@ - SUBROUTINE DLASRT( ID, N, D, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER ID - INTEGER INFO, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION D( * ) -* .. -* -* Purpose -* ======= -* -* Sort the numbers in D in increasing order (if ID = 'I') or -* in decreasing order (if ID = 'D' ). -* -* Use Quick Sort, reverting to Insertion sort on arrays of -* size <= 20. Dimension of STACK limits N to about 2**32. -* -* Arguments -* ========= -* -* ID (input) CHARACTER*1 -* = 'I': sort D in increasing order; -* = 'D': sort D in decreasing order. -* -* N (input) INTEGER -* The length of the array D. -* -* D (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the array to be sorted. -* On exit, D has been sorted into increasing order -* (D(1) <= ... <= D(N) ) or into decreasing order -* (D(1) >= ... >= D(N) ), depending on ID. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER SELECT - PARAMETER ( SELECT = 20 ) -* .. -* .. Local Scalars .. - INTEGER DIR, ENDD, I, J, START, STKPNT - DOUBLE PRECISION D1, D2, D3, DMNMX, TMP -* .. -* .. Local Arrays .. - INTEGER STACK( 2, 32 ) -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL XERBLA -* .. -* .. Executable Statements .. -* -* Test the input paramters. -* - INFO = 0 - DIR = -1 - IF( LSAME( ID, 'D' ) ) THEN - DIR = 0 - ELSE IF( LSAME( ID, 'I' ) ) THEN - DIR = 1 - END IF - IF( DIR.EQ.-1 ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLASRT', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.1 ) - $ RETURN -* - STKPNT = 1 - STACK( 1, 1 ) = 1 - STACK( 2, 1 ) = N - 10 CONTINUE - START = STACK( 1, STKPNT ) - ENDD = STACK( 2, STKPNT ) - STKPNT = STKPNT - 1 - IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN -* -* Do Insertion sort on D( START:ENDD ) -* - IF( DIR.EQ.0 ) THEN -* -* Sort into decreasing order -* - DO 30 I = START + 1, ENDD - DO 20 J = I, START + 1, -1 - IF( D( J ).GT.D( J-1 ) ) THEN - DMNMX = D( J ) - D( J ) = D( J-1 ) - D( J-1 ) = DMNMX - ELSE - GO TO 30 - END IF - 20 CONTINUE - 30 CONTINUE -* - ELSE -* -* Sort into increasing order -* - DO 50 I = START + 1, ENDD - DO 40 J = I, START + 1, -1 - IF( D( J ).LT.D( J-1 ) ) THEN - DMNMX = D( J ) - D( J ) = D( J-1 ) - D( J-1 ) = DMNMX - ELSE - GO TO 50 - END IF - 40 CONTINUE - 50 CONTINUE -* - END IF -* - ELSE IF( ENDD-START.GT.SELECT ) THEN -* -* Partition D( START:ENDD ) and stack parts, largest one first -* -* Choose partition entry as median of 3 -* - D1 = D( START ) - D2 = D( ENDD ) - I = ( START+ENDD ) / 2 - D3 = D( I ) - IF( D1.LT.D2 ) THEN - IF( D3.LT.D1 ) THEN - DMNMX = D1 - ELSE IF( D3.LT.D2 ) THEN - DMNMX = D3 - ELSE - DMNMX = D2 - END IF - ELSE - IF( D3.LT.D2 ) THEN - DMNMX = D2 - ELSE IF( D3.LT.D1 ) THEN - DMNMX = D3 - ELSE - DMNMX = D1 - END IF - END IF -* - IF( DIR.EQ.0 ) THEN -* -* Sort into decreasing order -* - I = START - 1 - J = ENDD + 1 - 60 CONTINUE - 70 CONTINUE - J = J - 1 - IF( D( J ).LT.DMNMX ) - $ GO TO 70 - 80 CONTINUE - I = I + 1 - IF( D( I ).GT.DMNMX ) - $ GO TO 80 - IF( I.LT.J ) THEN - TMP = D( I ) - D( I ) = D( J ) - D( J ) = TMP - GO TO 60 - END IF - IF( J-START.GT.ENDD-J-1 ) THEN - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - ELSE - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - END IF - ELSE -* -* Sort into increasing order -* - I = START - 1 - J = ENDD + 1 - 90 CONTINUE - 100 CONTINUE - J = J - 1 - IF( D( J ).GT.DMNMX ) - $ GO TO 100 - 110 CONTINUE - I = I + 1 - IF( D( I ).LT.DMNMX ) - $ GO TO 110 - IF( I.LT.J ) THEN - TMP = D( I ) - D( I ) = D( J ) - D( J ) = TMP - GO TO 90 - END IF - IF( J-START.GT.ENDD-J-1 ) THEN - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - ELSE - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = J + 1 - STACK( 2, STKPNT ) = ENDD - STKPNT = STKPNT + 1 - STACK( 1, STKPNT ) = START - STACK( 2, STKPNT ) = J - END IF - END IF - END IF - IF( STKPNT.GT.0 ) - $ GO TO 10 - RETURN -* -* End of DLASRT -* - END diff --git a/ext/lapack/dlassq.f b/ext/lapack/dlassq.f deleted file mode 100644 index 9518d06ab..000000000 --- a/ext/lapack/dlassq.f +++ /dev/null @@ -1,89 +0,0 @@ - SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION SCALE, SUMSQ -* .. -* .. Array Arguments .. - DOUBLE PRECISION X( * ) -* .. -* -* Purpose -* ======= -* -* DLASSQ returns the values scl and smsq such that -* -* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, -* -* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is -* assumed to be non-negative and scl returns the value -* -* scl = max( scale, abs( x( i ) ) ). -* -* scale and sumsq must be supplied in SCALE and SUMSQ and -* scl and smsq are overwritten on SCALE and SUMSQ respectively. -* -* The routine makes only one pass through the vector x. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of elements to be used from the vector X. -* -* X (input) DOUBLE PRECISION -* The vector for which a scaled sum of squares is computed. -* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. -* -* INCX (input) INTEGER -* The increment between successive values of the vector X. -* INCX > 0. -* -* SCALE (input/output) DOUBLE PRECISION -* On entry, the value scale in the equation above. -* On exit, SCALE is overwritten with scl , the scaling factor -* for the sum of squares. -* -* SUMSQ (input/output) DOUBLE PRECISION -* On entry, the value sumsq in the equation above. -* On exit, SUMSQ is overwritten with smsq , the basic sum of -* squares from which scl has been factored out. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER IX - DOUBLE PRECISION ABSXI -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* - IF( N.GT.0 ) THEN - DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX - IF( X( IX ).NE.ZERO ) THEN - ABSXI = ABS( X( IX ) ) - IF( SCALE.LT.ABSXI ) THEN - SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2 - SCALE = ABSXI - ELSE - SUMSQ = SUMSQ + ( ABSXI / SCALE )**2 - END IF - END IF - 10 CONTINUE - END IF - RETURN -* -* End of DLASSQ -* - END diff --git a/ext/lapack/dlasv2.f b/ext/lapack/dlasv2.f deleted file mode 100644 index 0fc7835dc..000000000 --- a/ext/lapack/dlasv2.f +++ /dev/null @@ -1,250 +0,0 @@ - SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* October 31, 1992 -* -* .. Scalar Arguments .. - DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN -* .. -* -* Purpose -* ======= -* -* DLASV2 computes the singular value decomposition of a 2-by-2 -* triangular matrix -* [ F G ] -* [ 0 H ]. -* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the -* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and -* right singular vectors for abs(SSMAX), giving the decomposition -* -* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] -* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. -* -* Arguments -* ========= -* -* F (input) DOUBLE PRECISION -* The (1,1) element of the 2-by-2 matrix. -* -* G (input) DOUBLE PRECISION -* The (1,2) element of the 2-by-2 matrix. -* -* H (input) DOUBLE PRECISION -* The (2,2) element of the 2-by-2 matrix. -* -* SSMIN (output) DOUBLE PRECISION -* abs(SSMIN) is the smaller singular value. -* -* SSMAX (output) DOUBLE PRECISION -* abs(SSMAX) is the larger singular value. -* -* SNL (output) DOUBLE PRECISION -* CSL (output) DOUBLE PRECISION -* The vector (CSL, SNL) is a unit left singular vector for the -* singular value abs(SSMAX). -* -* SNR (output) DOUBLE PRECISION -* CSR (output) DOUBLE PRECISION -* The vector (CSR, SNR) is a unit right singular vector for the -* singular value abs(SSMAX). -* -* Further Details -* =============== -* -* Any input parameter may be aliased with any output parameter. -* -* Barring over/underflow and assuming a guard digit in subtraction, all -* output quantities are correct to within a few units in the last -* place (ulps). -* -* In IEEE arithmetic, the code works correctly if one matrix element is -* infinite. -* -* Overflow will not occur unless the largest singular value itself -* overflows or is within a few ulps of overflow. (On machines with -* partial overflow, like the Cray, overflow may occur if the largest -* singular value is within a factor of 2 of overflow.) -* -* Underflow is harmless if underflow is gradual. Otherwise, results -* may correspond to a matrix modified by perturbations of size near -* the underflow threshold. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D0 ) - DOUBLE PRECISION HALF - PARAMETER ( HALF = 0.5D0 ) - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D0 ) - DOUBLE PRECISION TWO - PARAMETER ( TWO = 2.0D0 ) - DOUBLE PRECISION FOUR - PARAMETER ( FOUR = 4.0D0 ) -* .. -* .. Local Scalars .. - LOGICAL GASMAL, SWAP - INTEGER PMAX - DOUBLE PRECISION A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M, - $ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, SIGN, SQRT -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. Executable Statements .. -* - FT = F - FA = ABS( FT ) - HT = H - HA = ABS( H ) -* -* PMAX points to the maximum absolute element of matrix -* PMAX = 1 if F largest in absolute values -* PMAX = 2 if G largest in absolute values -* PMAX = 3 if H largest in absolute values -* - PMAX = 1 - SWAP = ( HA.GT.FA ) - IF( SWAP ) THEN - PMAX = 3 - TEMP = FT - FT = HT - HT = TEMP - TEMP = FA - FA = HA - HA = TEMP -* -* Now FA .ge. HA -* - END IF - GT = G - GA = ABS( GT ) - IF( GA.EQ.ZERO ) THEN -* -* Diagonal matrix -* - SSMIN = HA - SSMAX = FA - CLT = ONE - CRT = ONE - SLT = ZERO - SRT = ZERO - ELSE - GASMAL = .TRUE. - IF( GA.GT.FA ) THEN - PMAX = 2 - IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN -* -* Case of very large GA -* - GASMAL = .FALSE. - SSMAX = GA - IF( HA.GT.ONE ) THEN - SSMIN = FA / ( GA / HA ) - ELSE - SSMIN = ( FA / GA )*HA - END IF - CLT = ONE - SLT = HT / GT - SRT = ONE - CRT = FT / GT - END IF - END IF - IF( GASMAL ) THEN -* -* Normal case -* - D = FA - HA - IF( D.EQ.FA ) THEN -* -* Copes with infinite F or H -* - L = ONE - ELSE - L = D / FA - END IF -* -* Note that 0 .le. L .le. 1 -* - M = GT / FT -* -* Note that abs(M) .le. 1/macheps -* - T = TWO - L -* -* Note that T .ge. 1 -* - MM = M*M - TT = T*T - S = SQRT( TT+MM ) -* -* Note that 1 .le. S .le. 1 + 1/macheps -* - IF( L.EQ.ZERO ) THEN - R = ABS( M ) - ELSE - R = SQRT( L*L+MM ) - END IF -* -* Note that 0 .le. R .le. 1 + 1/macheps -* - A = HALF*( S+R ) -* -* Note that 1 .le. A .le. 1 + abs(M) -* - SSMIN = HA / A - SSMAX = FA*A - IF( MM.EQ.ZERO ) THEN -* -* Note that M is very tiny -* - IF( L.EQ.ZERO ) THEN - T = SIGN( TWO, FT )*SIGN( ONE, GT ) - ELSE - T = GT / SIGN( D, FT ) + M / T - END IF - ELSE - T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A ) - END IF - L = SQRT( T*T+FOUR ) - CRT = TWO / L - SRT = T / L - CLT = ( CRT+SRT*M ) / A - SLT = ( HT / FT )*SRT / A - END IF - END IF - IF( SWAP ) THEN - CSL = SRT - SNL = CRT - CSR = SLT - SNR = CLT - ELSE - CSL = CLT - SNL = SLT - CSR = CRT - SNR = SRT - END IF -* -* Correct signs of SSMAX and SSMIN -* - IF( PMAX.EQ.1 ) - $ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F ) - IF( PMAX.EQ.2 ) - $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G ) - IF( PMAX.EQ.3 ) - $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H ) - SSMAX = SIGN( SSMAX, TSIGN ) - SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) ) - RETURN -* -* End of DLASV2 -* - END diff --git a/ext/lapack/dlaswp.f b/ext/lapack/dlaswp.f deleted file mode 100644 index 99c0dda27..000000000 --- a/ext/lapack/dlaswp.f +++ /dev/null @@ -1,120 +0,0 @@ - SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1999 -* -* .. Scalar Arguments .. - INTEGER INCX, K1, K2, LDA, N -* .. -* .. Array Arguments .. - INTEGER IPIV( * ) - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DLASWP performs a series of row interchanges on the matrix A. -* One row interchange is initiated for each of rows K1 through K2 of A. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of columns of the matrix A. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the matrix of column dimension N to which the row -* interchanges will be applied. -* On exit, the permuted matrix. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* -* K1 (input) INTEGER -* The first element of IPIV for which a row interchange will -* be done. -* -* K2 (input) INTEGER -* The last element of IPIV for which a row interchange will -* be done. -* -* IPIV (input) INTEGER array, dimension (M*abs(INCX)) -* The vector of pivot indices. Only the elements in positions -* K1 through K2 of IPIV are accessed. -* IPIV(K) = L implies rows K and L are to be interchanged. -* -* INCX (input) INTEGER -* The increment between successive values of IPIV. If IPIV -* is negative, the pivots are applied in reverse order. -* -* Further Details -* =============== -* -* Modified by -* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA -* -* ===================================================================== -* -* .. Local Scalars .. - INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32 - DOUBLE PRECISION TEMP -* .. -* .. Executable Statements .. -* -* Interchange row I with row IPIV(I) for each of rows K1 through K2. -* - IF( INCX.GT.0 ) THEN - IX0 = K1 - I1 = K1 - I2 = K2 - INC = 1 - ELSE IF( INCX.LT.0 ) THEN - IX0 = 1 + ( 1-K2 )*INCX - I1 = K2 - I2 = K1 - INC = -1 - ELSE - RETURN - END IF -* - N32 = ( N / 32 )*32 - IF( N32.NE.0 ) THEN - DO 30 J = 1, N32, 32 - IX = IX0 - DO 20 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 10 K = J, J + 31 - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 10 CONTINUE - END IF - IX = IX + INCX - 20 CONTINUE - 30 CONTINUE - END IF - IF( N32.NE.N ) THEN - N32 = N32 + 1 - IX = IX0 - DO 50 I = I1, I2, INC - IP = IPIV( IX ) - IF( IP.NE.I ) THEN - DO 40 K = N32, N - TEMP = A( I, K ) - A( I, K ) = A( IP, K ) - A( IP, K ) = TEMP - 40 CONTINUE - END IF - IX = IX + INCX - 50 CONTINUE - END IF -* - RETURN -* -* End of DLASWP -* - END diff --git a/ext/lapack/dlatbs.f b/ext/lapack/dlatbs.f deleted file mode 100644 index fe7dd11cb..000000000 --- a/ext/lapack/dlatbs.f +++ /dev/null @@ -1,724 +0,0 @@ - SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, - $ SCALE, CNORM, INFO ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIAG, NORMIN, TRANS, UPLO - INTEGER INFO, KD, LDAB, N - DOUBLE PRECISION SCALE -* .. -* .. Array Arguments .. - DOUBLE PRECISION AB( LDAB, * ), CNORM( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DLATBS solves one of the triangular systems -* -* A *x = s*b or A'*x = s*b -* -* with scaling to prevent overflow, where A is an upper or lower -* triangular band matrix. Here A' denotes the transpose of A, x and b -* are n-element vectors, and s is a scaling factor, usually less than -* or equal to 1, chosen so that the components of x will be less than -* the overflow threshold. If the unscaled problem will not cause -* overflow, the Level 2 BLAS routine DTBSV is called. If the matrix A -* is singular (A(j,j) = 0 for some j), then s is set to 0 and a -* non-trivial solution to A*x = 0 is returned. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the matrix A is upper or lower triangular. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* TRANS (input) CHARACTER*1 -* Specifies the operation applied to A. -* = 'N': Solve A * x = s*b (No transpose) -* = 'T': Solve A'* x = s*b (Transpose) -* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) -* -* DIAG (input) CHARACTER*1 -* Specifies whether or not the matrix A is unit triangular. -* = 'N': Non-unit triangular -* = 'U': Unit triangular -* -* NORMIN (input) CHARACTER*1 -* Specifies whether CNORM has been set or not. -* = 'Y': CNORM contains the column norms on entry -* = 'N': CNORM is not set on entry. On exit, the norms will -* be computed and stored in CNORM. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* KD (input) INTEGER -* The number of subdiagonals or superdiagonals in the -* triangular matrix A. KD >= 0. -* -* AB (input) DOUBLE PRECISION array, dimension (LDAB,N) -* The upper or lower triangular band matrix A, stored in the -* first KD+1 rows of the array. The j-th column of A is stored -* in the j-th column of the array AB as follows: -* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; -* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). -* -* LDAB (input) INTEGER -* The leading dimension of the array AB. LDAB >= KD+1. -* -* X (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the right hand side b of the triangular system. -* On exit, X is overwritten by the solution vector x. -* -* SCALE (output) DOUBLE PRECISION -* The scaling factor s for the triangular system -* A * x = s*b or A'* x = s*b. -* If SCALE = 0, the matrix A is singular or badly scaled, and -* the vector x is an exact or approximate solution to A*x = 0. -* -* CNORM (input or output) DOUBLE PRECISION array, dimension (N) -* -* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) -* contains the norm of the off-diagonal part of the j-th column -* of A. If TRANS = 'N', CNORM(j) must be greater than or equal -* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) -* must be greater than or equal to the 1-norm. -* -* If NORMIN = 'N', CNORM is an output argument and CNORM(j) -* returns the 1-norm of the offdiagonal part of the j-th column -* of A. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* Further Details -* ======= ======= -* -* A rough bound on x is computed; if that is less than overflow, DTBSV -* is called, otherwise, specific code is used which checks for possible -* overflow or divide-by-zero at every operation. -* -* A columnwise scheme is used for solving A*x = b. The basic algorithm -* if A is lower triangular is -* -* x[1:n] := b[1:n] -* for j = 1, ..., n -* x(j) := x(j) / A(j,j) -* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] -* end -* -* Define bounds on the components of x after j iterations of the loop: -* M(j) = bound on x[1:j] -* G(j) = bound on x[j+1:n] -* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. -* -* Then for iteration j+1 we have -* M(j+1) <= G(j) / | A(j+1,j+1) | -* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | -* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) -* -* where CNORM(j+1) is greater than or equal to the infinity-norm of -* column j+1 of A, not counting the diagonal. Hence -* -* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) -* 1<=i<=j -* and -* -* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) -* 1<=i< j -* -* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the -* reciprocal of the largest M(j), j=1,..,n, is larger than -* max(underflow, 1/overflow). -* -* The bound on x(j) is also used to determine when a step in the -* columnwise method can be performed without fear of overflow. If -* the computed bound is greater than a large constant, x is scaled to -* prevent overflow, but if the bound overflows, x is set to 0, x(j) to -* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. -* -* Similarly, a row-wise scheme is used to solve A'*x = b. The basic -* algorithm for A upper triangular is -* -* for j = 1, ..., n -* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) -* end -* -* We simultaneously compute two bounds -* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j -* M(j) = bound on x(i), 1<=i<=j -* -* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we -* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. -* Then the bound on x(j) is -* -* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | -* -* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) -* 1<=i<=j -* -* and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater -* than max(underflow, 1/overflow). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN, NOUNIT, UPPER - INTEGER I, IMAX, J, JFIRST, JINC, JLAST, JLEN, MAIND - DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS, - $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DASUM, DDOT, DLAMCH - EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DSCAL, DTBSV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Executable Statements .. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOTRAN = LSAME( TRANS, 'N' ) - NOUNIT = LSAME( DIAG, 'N' ) -* -* Test the input parameters. -* - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -3 - ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. - $ LSAME( NORMIN, 'N' ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( KD.LT.0 ) THEN - INFO = -6 - ELSE IF( LDAB.LT.KD+1 ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLATBS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine machine dependent parameters to control overflow. -* - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - SCALE = ONE -* - IF( LSAME( NORMIN, 'N' ) ) THEN -* -* Compute the 1-norm of each column, not including the diagonal. -* - IF( UPPER ) THEN -* -* A is upper triangular. -* - DO 10 J = 1, N - JLEN = MIN( KD, J-1 ) - CNORM( J ) = DASUM( JLEN, AB( KD+1-JLEN, J ), 1 ) - 10 CONTINUE - ELSE -* -* A is lower triangular. -* - DO 20 J = 1, N - JLEN = MIN( KD, N-J ) - IF( JLEN.GT.0 ) THEN - CNORM( J ) = DASUM( JLEN, AB( 2, J ), 1 ) - ELSE - CNORM( J ) = ZERO - END IF - 20 CONTINUE - END IF - END IF -* -* Scale the column norms by TSCAL if the maximum element in CNORM is -* greater than BIGNUM. -* - IMAX = IDAMAX( N, CNORM, 1 ) - TMAX = CNORM( IMAX ) - IF( TMAX.LE.BIGNUM ) THEN - TSCAL = ONE - ELSE - TSCAL = ONE / ( SMLNUM*TMAX ) - CALL DSCAL( N, TSCAL, CNORM, 1 ) - END IF -* -* Compute a bound on the computed solution vector to see if the -* Level 2 BLAS routine DTBSV can be used. -* - J = IDAMAX( N, X, 1 ) - XMAX = ABS( X( J ) ) - XBND = XMAX - IF( NOTRAN ) THEN -* -* Compute the growth in A * x = b. -* - IF( UPPER ) THEN - JFIRST = N - JLAST = 1 - JINC = -1 - MAIND = KD + 1 - ELSE - JFIRST = 1 - JLAST = N - JINC = 1 - MAIND = 1 - END IF -* - IF( TSCAL.NE.ONE ) THEN - GROW = ZERO - GO TO 50 - END IF -* - IF( NOUNIT ) THEN -* -* A is non-unit triangular. -* -* Compute GROW = 1/G(j) and XBND = 1/M(j). -* Initially, G(0) = max{x(i), i=1,...,n}. -* - GROW = ONE / MAX( XBND, SMLNUM ) - XBND = GROW - DO 30 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 50 -* -* M(j) = G(j-1) / abs(A(j,j)) -* - TJJ = ABS( AB( MAIND, J ) ) - XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) - IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN -* -* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) -* - GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) - ELSE -* -* G(j) could overflow, set GROW to 0. -* - GROW = ZERO - END IF - 30 CONTINUE - GROW = XBND - ELSE -* -* A is unit triangular. -* -* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. -* - GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) - DO 40 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 50 -* -* G(j) = G(j-1)*( 1 + CNORM(j) ) -* - GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) - 40 CONTINUE - END IF - 50 CONTINUE -* - ELSE -* -* Compute the growth in A' * x = b. -* - IF( UPPER ) THEN - JFIRST = 1 - JLAST = N - JINC = 1 - MAIND = KD + 1 - ELSE - JFIRST = N - JLAST = 1 - JINC = -1 - MAIND = 1 - END IF -* - IF( TSCAL.NE.ONE ) THEN - GROW = ZERO - GO TO 80 - END IF -* - IF( NOUNIT ) THEN -* -* A is non-unit triangular. -* -* Compute GROW = 1/G(j) and XBND = 1/M(j). -* Initially, M(0) = max{x(i), i=1,...,n}. -* - GROW = ONE / MAX( XBND, SMLNUM ) - XBND = GROW - DO 60 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 80 -* -* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) -* - XJ = ONE + CNORM( J ) - GROW = MIN( GROW, XBND / XJ ) -* -* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) -* - TJJ = ABS( AB( MAIND, J ) ) - IF( XJ.GT.TJJ ) - $ XBND = XBND*( TJJ / XJ ) - 60 CONTINUE - GROW = MIN( GROW, XBND ) - ELSE -* -* A is unit triangular. -* -* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. -* - GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) - DO 70 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 80 -* -* G(j) = ( 1 + CNORM(j) )*G(j-1) -* - XJ = ONE + CNORM( J ) - GROW = GROW / XJ - 70 CONTINUE - END IF - 80 CONTINUE - END IF -* - IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN -* -* Use the Level 2 BLAS solve if the reciprocal of the bound on -* elements of X is not too small. -* - CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, X, 1 ) - ELSE -* -* Use a Level 1 BLAS solve, scaling intermediate results. -* - IF( XMAX.GT.BIGNUM ) THEN -* -* Scale X so that its components are less than or equal to -* BIGNUM in absolute value. -* - SCALE = BIGNUM / XMAX - CALL DSCAL( N, SCALE, X, 1 ) - XMAX = BIGNUM - END IF -* - IF( NOTRAN ) THEN -* -* Solve A * x = b -* - DO 110 J = JFIRST, JLAST, JINC -* -* Compute x(j) = b(j) / A(j,j), scaling x if necessary. -* - XJ = ABS( X( J ) ) - IF( NOUNIT ) THEN - TJJS = AB( MAIND, J )*TSCAL - ELSE - TJJS = TSCAL - IF( TSCAL.EQ.ONE ) - $ GO TO 100 - END IF - TJJ = ABS( TJJS ) - IF( TJJ.GT.SMLNUM ) THEN -* -* abs(A(j,j)) > SMLNUM: -* - IF( TJJ.LT.ONE ) THEN - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale x by 1/b(j). -* - REC = ONE / XJ - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - END IF - X( J ) = X( J ) / TJJS - XJ = ABS( X( J ) ) - ELSE IF( TJJ.GT.ZERO ) THEN -* -* 0 < abs(A(j,j)) <= SMLNUM: -* - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM -* to avoid overflow when dividing by A(j,j). -* - REC = ( TJJ*BIGNUM ) / XJ - IF( CNORM( J ).GT.ONE ) THEN -* -* Scale by 1/CNORM(j) to avoid overflow when -* multiplying x(j) times column j. -* - REC = REC / CNORM( J ) - END IF - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - X( J ) = X( J ) / TJJS - XJ = ABS( X( J ) ) - ELSE -* -* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and -* scale = 0, and compute a solution to A*x = 0. -* - DO 90 I = 1, N - X( I ) = ZERO - 90 CONTINUE - X( J ) = ONE - XJ = ONE - SCALE = ZERO - XMAX = ZERO - END IF - 100 CONTINUE -* -* Scale x if necessary to avoid overflow when adding a -* multiple of column j of A. -* - IF( XJ.GT.ONE ) THEN - REC = ONE / XJ - IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN -* -* Scale x by 1/(2*abs(x(j))). -* - REC = REC*HALF - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - END IF - ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN -* -* Scale x by 1/2. -* - CALL DSCAL( N, HALF, X, 1 ) - SCALE = SCALE*HALF - END IF -* - IF( UPPER ) THEN - IF( J.GT.1 ) THEN -* -* Compute the update -* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - -* x(j)* A(max(1,j-kd):j-1,j) -* - JLEN = MIN( KD, J-1 ) - CALL DAXPY( JLEN, -X( J )*TSCAL, - $ AB( KD+1-JLEN, J ), 1, X( J-JLEN ), 1 ) - I = IDAMAX( J-1, X, 1 ) - XMAX = ABS( X( I ) ) - END IF - ELSE IF( J.LT.N ) THEN -* -* Compute the update -* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) - -* x(j) * A(j+1:min(j+kd,n),j) -* - JLEN = MIN( KD, N-J ) - IF( JLEN.GT.0 ) - $ CALL DAXPY( JLEN, -X( J )*TSCAL, AB( 2, J ), 1, - $ X( J+1 ), 1 ) - I = J + IDAMAX( N-J, X( J+1 ), 1 ) - XMAX = ABS( X( I ) ) - END IF - 110 CONTINUE -* - ELSE -* -* Solve A' * x = b -* - DO 160 J = JFIRST, JLAST, JINC -* -* Compute x(j) = b(j) - sum A(k,j)*x(k). -* k<>j -* - XJ = ABS( X( J ) ) - USCAL = TSCAL - REC = ONE / MAX( XMAX, ONE ) - IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN -* -* If x(j) could overflow, scale x by 1/(2*XMAX). -* - REC = REC*HALF - IF( NOUNIT ) THEN - TJJS = AB( MAIND, J )*TSCAL - ELSE - TJJS = TSCAL - END IF - TJJ = ABS( TJJS ) - IF( TJJ.GT.ONE ) THEN -* -* Divide by A(j,j) when scaling x if A(j,j) > 1. -* - REC = MIN( ONE, REC*TJJ ) - USCAL = USCAL / TJJS - END IF - IF( REC.LT.ONE ) THEN - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - END IF -* - SUMJ = ZERO - IF( USCAL.EQ.ONE ) THEN -* -* If the scaling needed for A in the dot product is 1, -* call DDOT to perform the dot product. -* - IF( UPPER ) THEN - JLEN = MIN( KD, J-1 ) - SUMJ = DDOT( JLEN, AB( KD+1-JLEN, J ), 1, - $ X( J-JLEN ), 1 ) - ELSE - JLEN = MIN( KD, N-J ) - IF( JLEN.GT.0 ) - $ SUMJ = DDOT( JLEN, AB( 2, J ), 1, X( J+1 ), 1 ) - END IF - ELSE -* -* Otherwise, use in-line code for the dot product. -* - IF( UPPER ) THEN - JLEN = MIN( KD, J-1 ) - DO 120 I = 1, JLEN - SUMJ = SUMJ + ( AB( KD+I-JLEN, J )*USCAL )* - $ X( J-JLEN-1+I ) - 120 CONTINUE - ELSE - JLEN = MIN( KD, N-J ) - DO 130 I = 1, JLEN - SUMJ = SUMJ + ( AB( I+1, J )*USCAL )*X( J+I ) - 130 CONTINUE - END IF - END IF -* - IF( USCAL.EQ.TSCAL ) THEN -* -* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) -* was not used to scale the dotproduct. -* - X( J ) = X( J ) - SUMJ - XJ = ABS( X( J ) ) - IF( NOUNIT ) THEN -* -* Compute x(j) = x(j) / A(j,j), scaling if necessary. -* - TJJS = AB( MAIND, J )*TSCAL - ELSE - TJJS = TSCAL - IF( TSCAL.EQ.ONE ) - $ GO TO 150 - END IF - TJJ = ABS( TJJS ) - IF( TJJ.GT.SMLNUM ) THEN -* -* abs(A(j,j)) > SMLNUM: -* - IF( TJJ.LT.ONE ) THEN - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale X by 1/abs(x(j)). -* - REC = ONE / XJ - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - END IF - X( J ) = X( J ) / TJJS - ELSE IF( TJJ.GT.ZERO ) THEN -* -* 0 < abs(A(j,j)) <= SMLNUM: -* - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. -* - REC = ( TJJ*BIGNUM ) / XJ - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - X( J ) = X( J ) / TJJS - ELSE -* -* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and -* scale = 0, and compute a solution to A'*x = 0. -* - DO 140 I = 1, N - X( I ) = ZERO - 140 CONTINUE - X( J ) = ONE - SCALE = ZERO - XMAX = ZERO - END IF - 150 CONTINUE - ELSE -* -* Compute x(j) := x(j) / A(j,j) - sumj if the dot -* product has already been divided by 1/A(j,j). -* - X( J ) = X( J ) / TJJS - SUMJ - END IF - XMAX = MAX( XMAX, ABS( X( J ) ) ) - 160 CONTINUE - END IF - SCALE = SCALE / TSCAL - END IF -* -* Scale the column norms by 1/TSCAL for return. -* - IF( TSCAL.NE.ONE ) THEN - CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) - END IF -* - RETURN -* -* End of DLATBS -* - END diff --git a/ext/lapack/dlatrs.f b/ext/lapack/dlatrs.f deleted file mode 100644 index 591c966d2..000000000 --- a/ext/lapack/dlatrs.f +++ /dev/null @@ -1,702 +0,0 @@ - SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, - $ CNORM, INFO ) -* -* -- LAPACK auxiliary routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* June 30, 1992 -* -* .. Scalar Arguments .. - CHARACTER DIAG, NORMIN, TRANS, UPLO - INTEGER INFO, LDA, N - DOUBLE PRECISION SCALE -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * ) -* .. -* -* Purpose -* ======= -* -* DLATRS solves one of the triangular systems -* -* A *x = s*b or A'*x = s*b -* -* with scaling to prevent overflow. Here A is an upper or lower -* triangular matrix, A' denotes the transpose of A, x and b are -* n-element vectors, and s is a scaling factor, usually less than -* or equal to 1, chosen so that the components of x will be less than -* the overflow threshold. If the unscaled problem will not cause -* overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A -* is singular (A(j,j) = 0 for some j), then s is set to 0 and a -* non-trivial solution to A*x = 0 is returned. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the matrix A is upper or lower triangular. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* TRANS (input) CHARACTER*1 -* Specifies the operation applied to A. -* = 'N': Solve A * x = s*b (No transpose) -* = 'T': Solve A'* x = s*b (Transpose) -* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) -* -* DIAG (input) CHARACTER*1 -* Specifies whether or not the matrix A is unit triangular. -* = 'N': Non-unit triangular -* = 'U': Unit triangular -* -* NORMIN (input) CHARACTER*1 -* Specifies whether CNORM has been set or not. -* = 'Y': CNORM contains the column norms on entry -* = 'N': CNORM is not set on entry. On exit, the norms will -* be computed and stored in CNORM. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The triangular matrix A. If UPLO = 'U', the leading n by n -* upper triangular part of the array A contains the upper -* triangular matrix, and the strictly lower triangular part of -* A is not referenced. If UPLO = 'L', the leading n by n lower -* triangular part of the array A contains the lower triangular -* matrix, and the strictly upper triangular part of A is not -* referenced. If DIAG = 'U', the diagonal elements of A are -* also not referenced and are assumed to be 1. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max (1,N). -* -* X (input/output) DOUBLE PRECISION array, dimension (N) -* On entry, the right hand side b of the triangular system. -* On exit, X is overwritten by the solution vector x. -* -* SCALE (output) DOUBLE PRECISION -* The scaling factor s for the triangular system -* A * x = s*b or A'* x = s*b. -* If SCALE = 0, the matrix A is singular or badly scaled, and -* the vector x is an exact or approximate solution to A*x = 0. -* -* CNORM (input or output) DOUBLE PRECISION array, dimension (N) -* -* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) -* contains the norm of the off-diagonal part of the j-th column -* of A. If TRANS = 'N', CNORM(j) must be greater than or equal -* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) -* must be greater than or equal to the 1-norm. -* -* If NORMIN = 'N', CNORM is an output argument and CNORM(j) -* returns the 1-norm of the offdiagonal part of the j-th column -* of A. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* -* Further Details -* ======= ======= -* -* A rough bound on x is computed; if that is less than overflow, DTRSV -* is called, otherwise, specific code is used which checks for possible -* overflow or divide-by-zero at every operation. -* -* A columnwise scheme is used for solving A*x = b. The basic algorithm -* if A is lower triangular is -* -* x[1:n] := b[1:n] -* for j = 1, ..., n -* x(j) := x(j) / A(j,j) -* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] -* end -* -* Define bounds on the components of x after j iterations of the loop: -* M(j) = bound on x[1:j] -* G(j) = bound on x[j+1:n] -* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. -* -* Then for iteration j+1 we have -* M(j+1) <= G(j) / | A(j+1,j+1) | -* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | -* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) -* -* where CNORM(j+1) is greater than or equal to the infinity-norm of -* column j+1 of A, not counting the diagonal. Hence -* -* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) -* 1<=i<=j -* and -* -* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) -* 1<=i< j -* -* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the -* reciprocal of the largest M(j), j=1,..,n, is larger than -* max(underflow, 1/overflow). -* -* The bound on x(j) is also used to determine when a step in the -* columnwise method can be performed without fear of overflow. If -* the computed bound is greater than a large constant, x is scaled to -* prevent overflow, but if the bound overflows, x is set to 0, x(j) to -* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. -* -* Similarly, a row-wise scheme is used to solve A'*x = b. The basic -* algorithm for A upper triangular is -* -* for j = 1, ..., n -* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) -* end -* -* We simultaneously compute two bounds -* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j -* M(j) = bound on x(i), 1<=i<=j -* -* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we -* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. -* Then the bound on x(j) is -* -* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | -* -* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) -* 1<=i<=j -* -* and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater -* than max(underflow, 1/overflow). -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, HALF, ONE - PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOTRAN, NOUNIT, UPPER - INTEGER I, IMAX, J, JFIRST, JINC, JLAST - DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS, - $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DASUM, DDOT, DLAMCH - EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DAXPY, DSCAL, DTRSV, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, MAX, MIN -* .. -* .. Executable Statements .. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - NOTRAN = LSAME( TRANS, 'N' ) - NOUNIT = LSAME( DIAG, 'N' ) -* -* Test the input parameters. -* - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT. - $ LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -3 - ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT. - $ LSAME( NORMIN, 'N' ) ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DLATRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine machine dependent parameters to control overflow. -* - SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' ) - BIGNUM = ONE / SMLNUM - SCALE = ONE -* - IF( LSAME( NORMIN, 'N' ) ) THEN -* -* Compute the 1-norm of each column, not including the diagonal. -* - IF( UPPER ) THEN -* -* A is upper triangular. -* - DO 10 J = 1, N - CNORM( J ) = DASUM( J-1, A( 1, J ), 1 ) - 10 CONTINUE - ELSE -* -* A is lower triangular. -* - DO 20 J = 1, N - 1 - CNORM( J ) = DASUM( N-J, A( J+1, J ), 1 ) - 20 CONTINUE - CNORM( N ) = ZERO - END IF - END IF -* -* Scale the column norms by TSCAL if the maximum element in CNORM is -* greater than BIGNUM. -* - IMAX = IDAMAX( N, CNORM, 1 ) - TMAX = CNORM( IMAX ) - IF( TMAX.LE.BIGNUM ) THEN - TSCAL = ONE - ELSE - TSCAL = ONE / ( SMLNUM*TMAX ) - CALL DSCAL( N, TSCAL, CNORM, 1 ) - END IF -* -* Compute a bound on the computed solution vector to see if the -* Level 2 BLAS routine DTRSV can be used. -* - J = IDAMAX( N, X, 1 ) - XMAX = ABS( X( J ) ) - XBND = XMAX - IF( NOTRAN ) THEN -* -* Compute the growth in A * x = b. -* - IF( UPPER ) THEN - JFIRST = N - JLAST = 1 - JINC = -1 - ELSE - JFIRST = 1 - JLAST = N - JINC = 1 - END IF -* - IF( TSCAL.NE.ONE ) THEN - GROW = ZERO - GO TO 50 - END IF -* - IF( NOUNIT ) THEN -* -* A is non-unit triangular. -* -* Compute GROW = 1/G(j) and XBND = 1/M(j). -* Initially, G(0) = max{x(i), i=1,...,n}. -* - GROW = ONE / MAX( XBND, SMLNUM ) - XBND = GROW - DO 30 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 50 -* -* M(j) = G(j-1) / abs(A(j,j)) -* - TJJ = ABS( A( J, J ) ) - XBND = MIN( XBND, MIN( ONE, TJJ )*GROW ) - IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN -* -* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) -* - GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) ) - ELSE -* -* G(j) could overflow, set GROW to 0. -* - GROW = ZERO - END IF - 30 CONTINUE - GROW = XBND - ELSE -* -* A is unit triangular. -* -* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. -* - GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) - DO 40 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 50 -* -* G(j) = G(j-1)*( 1 + CNORM(j) ) -* - GROW = GROW*( ONE / ( ONE+CNORM( J ) ) ) - 40 CONTINUE - END IF - 50 CONTINUE -* - ELSE -* -* Compute the growth in A' * x = b. -* - IF( UPPER ) THEN - JFIRST = 1 - JLAST = N - JINC = 1 - ELSE - JFIRST = N - JLAST = 1 - JINC = -1 - END IF -* - IF( TSCAL.NE.ONE ) THEN - GROW = ZERO - GO TO 80 - END IF -* - IF( NOUNIT ) THEN -* -* A is non-unit triangular. -* -* Compute GROW = 1/G(j) and XBND = 1/M(j). -* Initially, M(0) = max{x(i), i=1,...,n}. -* - GROW = ONE / MAX( XBND, SMLNUM ) - XBND = GROW - DO 60 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 80 -* -* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) -* - XJ = ONE + CNORM( J ) - GROW = MIN( GROW, XBND / XJ ) -* -* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) -* - TJJ = ABS( A( J, J ) ) - IF( XJ.GT.TJJ ) - $ XBND = XBND*( TJJ / XJ ) - 60 CONTINUE - GROW = MIN( GROW, XBND ) - ELSE -* -* A is unit triangular. -* -* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. -* - GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) ) - DO 70 J = JFIRST, JLAST, JINC -* -* Exit the loop if the growth factor is too small. -* - IF( GROW.LE.SMLNUM ) - $ GO TO 80 -* -* G(j) = ( 1 + CNORM(j) )*G(j-1) -* - XJ = ONE + CNORM( J ) - GROW = GROW / XJ - 70 CONTINUE - END IF - 80 CONTINUE - END IF -* - IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN -* -* Use the Level 2 BLAS solve if the reciprocal of the bound on -* elements of X is not too small. -* - CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 ) - ELSE -* -* Use a Level 1 BLAS solve, scaling intermediate results. -* - IF( XMAX.GT.BIGNUM ) THEN -* -* Scale X so that its components are less than or equal to -* BIGNUM in absolute value. -* - SCALE = BIGNUM / XMAX - CALL DSCAL( N, SCALE, X, 1 ) - XMAX = BIGNUM - END IF -* - IF( NOTRAN ) THEN -* -* Solve A * x = b -* - DO 110 J = JFIRST, JLAST, JINC -* -* Compute x(j) = b(j) / A(j,j), scaling x if necessary. -* - XJ = ABS( X( J ) ) - IF( NOUNIT ) THEN - TJJS = A( J, J )*TSCAL - ELSE - TJJS = TSCAL - IF( TSCAL.EQ.ONE ) - $ GO TO 100 - END IF - TJJ = ABS( TJJS ) - IF( TJJ.GT.SMLNUM ) THEN -* -* abs(A(j,j)) > SMLNUM: -* - IF( TJJ.LT.ONE ) THEN - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale x by 1/b(j). -* - REC = ONE / XJ - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - END IF - X( J ) = X( J ) / TJJS - XJ = ABS( X( J ) ) - ELSE IF( TJJ.GT.ZERO ) THEN -* -* 0 < abs(A(j,j)) <= SMLNUM: -* - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM -* to avoid overflow when dividing by A(j,j). -* - REC = ( TJJ*BIGNUM ) / XJ - IF( CNORM( J ).GT.ONE ) THEN -* -* Scale by 1/CNORM(j) to avoid overflow when -* multiplying x(j) times column j. -* - REC = REC / CNORM( J ) - END IF - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - X( J ) = X( J ) / TJJS - XJ = ABS( X( J ) ) - ELSE -* -* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and -* scale = 0, and compute a solution to A*x = 0. -* - DO 90 I = 1, N - X( I ) = ZERO - 90 CONTINUE - X( J ) = ONE - XJ = ONE - SCALE = ZERO - XMAX = ZERO - END IF - 100 CONTINUE -* -* Scale x if necessary to avoid overflow when adding a -* multiple of column j of A. -* - IF( XJ.GT.ONE ) THEN - REC = ONE / XJ - IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN -* -* Scale x by 1/(2*abs(x(j))). -* - REC = REC*HALF - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - END IF - ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN -* -* Scale x by 1/2. -* - CALL DSCAL( N, HALF, X, 1 ) - SCALE = SCALE*HALF - END IF -* - IF( UPPER ) THEN - IF( J.GT.1 ) THEN -* -* Compute the update -* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) -* - CALL DAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X, - $ 1 ) - I = IDAMAX( J-1, X, 1 ) - XMAX = ABS( X( I ) ) - END IF - ELSE - IF( J.LT.N ) THEN -* -* Compute the update -* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) -* - CALL DAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1, - $ X( J+1 ), 1 ) - I = J + IDAMAX( N-J, X( J+1 ), 1 ) - XMAX = ABS( X( I ) ) - END IF - END IF - 110 CONTINUE -* - ELSE -* -* Solve A' * x = b -* - DO 160 J = JFIRST, JLAST, JINC -* -* Compute x(j) = b(j) - sum A(k,j)*x(k). -* k<>j -* - XJ = ABS( X( J ) ) - USCAL = TSCAL - REC = ONE / MAX( XMAX, ONE ) - IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN -* -* If x(j) could overflow, scale x by 1/(2*XMAX). -* - REC = REC*HALF - IF( NOUNIT ) THEN - TJJS = A( J, J )*TSCAL - ELSE - TJJS = TSCAL - END IF - TJJ = ABS( TJJS ) - IF( TJJ.GT.ONE ) THEN -* -* Divide by A(j,j) when scaling x if A(j,j) > 1. -* - REC = MIN( ONE, REC*TJJ ) - USCAL = USCAL / TJJS - END IF - IF( REC.LT.ONE ) THEN - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - END IF -* - SUMJ = ZERO - IF( USCAL.EQ.ONE ) THEN -* -* If the scaling needed for A in the dot product is 1, -* call DDOT to perform the dot product. -* - IF( UPPER ) THEN - SUMJ = DDOT( J-1, A( 1, J ), 1, X, 1 ) - ELSE IF( J.LT.N ) THEN - SUMJ = DDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 ) - END IF - ELSE -* -* Otherwise, use in-line code for the dot product. -* - IF( UPPER ) THEN - DO 120 I = 1, J - 1 - SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I ) - 120 CONTINUE - ELSE IF( J.LT.N ) THEN - DO 130 I = J + 1, N - SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I ) - 130 CONTINUE - END IF - END IF -* - IF( USCAL.EQ.TSCAL ) THEN -* -* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) -* was not used to scale the dotproduct. -* - X( J ) = X( J ) - SUMJ - XJ = ABS( X( J ) ) - IF( NOUNIT ) THEN - TJJS = A( J, J )*TSCAL - ELSE - TJJS = TSCAL - IF( TSCAL.EQ.ONE ) - $ GO TO 150 - END IF -* -* Compute x(j) = x(j) / A(j,j), scaling if necessary. -* - TJJ = ABS( TJJS ) - IF( TJJ.GT.SMLNUM ) THEN -* -* abs(A(j,j)) > SMLNUM: -* - IF( TJJ.LT.ONE ) THEN - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale X by 1/abs(x(j)). -* - REC = ONE / XJ - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - END IF - X( J ) = X( J ) / TJJS - ELSE IF( TJJ.GT.ZERO ) THEN -* -* 0 < abs(A(j,j)) <= SMLNUM: -* - IF( XJ.GT.TJJ*BIGNUM ) THEN -* -* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. -* - REC = ( TJJ*BIGNUM ) / XJ - CALL DSCAL( N, REC, X, 1 ) - SCALE = SCALE*REC - XMAX = XMAX*REC - END IF - X( J ) = X( J ) / TJJS - ELSE -* -* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and -* scale = 0, and compute a solution to A'*x = 0. -* - DO 140 I = 1, N - X( I ) = ZERO - 140 CONTINUE - X( J ) = ONE - SCALE = ZERO - XMAX = ZERO - END IF - 150 CONTINUE - ELSE -* -* Compute x(j) := x(j) / A(j,j) - sumj if the dot -* product has already been divided by 1/A(j,j). -* - X( J ) = X( J ) / TJJS - SUMJ - END IF - XMAX = MAX( XMAX, ABS( X( J ) ) ) - 160 CONTINUE - END IF - SCALE = SCALE / TSCAL - END IF -* -* Scale the column norms by 1/TSCAL for return. -* - IF( TSCAL.NE.ONE ) THEN - CALL DSCAL( N, ONE / TSCAL, CNORM, 1 ) - END IF -* - RETURN -* -* End of DLATRS -* - END diff --git a/ext/lapack/dorg2r.f b/ext/lapack/dorg2r.f deleted file mode 100644 index 8ecd83de6..000000000 --- a/ext/lapack/dorg2r.f +++ /dev/null @@ -1,130 +0,0 @@ - SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORG2R generates an m by n real matrix Q with orthonormal columns, -* which is defined as the first n columns of a product of k elementary -* reflectors of order m -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. M >= N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. N >= K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the i-th column must contain the vector which -* defines the elementary reflector H(i), for i = 1,2,...,k, as -* returned by DGEQRF in the first k columns of its array -* argument A. -* On exit, the m-by-n matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORG2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Initialise columns k+1:n to columns of the unit matrix -* - DO 20 J = K + 1, N - DO 10 L = 1, M - A( L, J ) = ZERO - 10 CONTINUE - A( J, J ) = ONE - 20 CONTINUE -* - DO 40 I = K, 1, -1 -* -* Apply H(i) to A(i:m,i:n) from the left -* - IF( I.LT.N ) THEN - A( I, I ) = ONE - CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ), - $ A( I, I+1 ), LDA, WORK ) - END IF - IF( I.LT.M ) - $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 ) - A( I, I ) = ONE - TAU( I ) -* -* Set A(1:i-1,i) to zero -* - DO 30 L = 1, I - 1 - A( L, I ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of DORG2R -* - END diff --git a/ext/lapack/dorgbr.f b/ext/lapack/dorgbr.f deleted file mode 100644 index ed8aa80ac..000000000 --- a/ext/lapack/dorgbr.f +++ /dev/null @@ -1,223 +0,0 @@ - SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER VECT - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DORGBR generates one of the real orthogonal matrices Q or P**T -* determined by DGEBRD when reducing a real matrix A to bidiagonal -* form: A = Q * B * P**T. Q and P**T are defined as products of -* elementary reflectors H(i) or G(i) respectively. -* -* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q -* is of order M: -* if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n -* columns of Q, where m >= n >= k; -* if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an -* M-by-M matrix. -* -* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T -* is of order N: -* if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m -* rows of P**T, where n >= m >= k; -* if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as -* an N-by-N matrix. -* -* Arguments -* ========= -* -* VECT (input) CHARACTER*1 -* Specifies whether the matrix Q or the matrix P**T is -* required, as defined in the transformation applied by DGEBRD: -* = 'Q': generate Q; -* = 'P': generate P**T. -* -* M (input) INTEGER -* The number of rows of the matrix Q or P**T to be returned. -* M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q or P**T to be returned. -* N >= 0. -* If VECT = 'Q', M >= N >= min(M,K); -* if VECT = 'P', N >= M >= min(N,K). -* -* K (input) INTEGER -* If VECT = 'Q', the number of columns in the original M-by-K -* matrix reduced by DGEBRD. -* If VECT = 'P', the number of rows in the original K-by-N -* matrix reduced by DGEBRD. -* K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the vectors which define the elementary reflectors, -* as returned by DGEBRD. -* On exit, the M-by-N matrix Q or P**T. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension -* (min(M,K)) if VECT = 'Q' -* (min(N,K)) if VECT = 'P' -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i) or G(i), which determines Q or P**T, as -* returned by DGEBRD in its array argument TAUQ or TAUP. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,min(M,N)). -* For optimum performance LWORK >= min(M,N)*NB, where NB -* is the optimal blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL WANTQ - INTEGER I, IINFO, J -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DORGLQ, DORGQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - WANTQ = LSAME( VECT, 'Q' ) - IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN - INFO = -1 - ELSE IF( M.LT.0 ) THEN - INFO = -2 - ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M, - $ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT. - $ MIN( N, K ) ) ) ) THEN - INFO = -3 - ELSE IF( K.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -6 - ELSE IF( LWORK.LT.MAX( 1, MIN( M, N ) ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGBR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* - IF( WANTQ ) THEN -* -* Form Q, determined by a call to DGEBRD to reduce an m-by-k -* matrix -* - IF( M.GE.K ) THEN -* -* If m >= k, assume m >= n >= k -* - CALL DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* If m < k, assume m = n -* -* Shift the vectors which define the elementary reflectors one -* column to the right, and set the first row and column of Q -* to those of the unit matrix -* - DO 20 J = M, 2, -1 - A( 1, J ) = ZERO - DO 10 I = J + 1, M - A( I, J ) = A( I, J-1 ) - 10 CONTINUE - 20 CONTINUE - A( 1, 1 ) = ONE - DO 30 I = 2, M - A( I, 1 ) = ZERO - 30 CONTINUE - IF( M.GT.1 ) THEN -* -* Form Q(2:m,2:m) -* - CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - ELSE -* -* Form P', determined by a call to DGEBRD to reduce a k-by-n -* matrix -* - IF( K.LT.N ) THEN -* -* If k < n, assume k <= m <= n -* - CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO ) -* - ELSE -* -* If k >= n, assume m = n -* -* Shift the vectors which define the elementary reflectors one -* row downward, and set the first row and column of P' to -* those of the unit matrix -* - A( 1, 1 ) = ONE - DO 40 I = 2, N - A( I, 1 ) = ZERO - 40 CONTINUE - DO 60 J = 2, N - DO 50 I = J - 1, 2, -1 - A( I, J ) = A( I-1, J ) - 50 CONTINUE - A( 1, J ) = ZERO - 60 CONTINUE - IF( N.GT.1 ) THEN -* -* Form P'(2:n,2:n) -* - CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK, - $ LWORK, IINFO ) - END IF - END IF - END IF - RETURN -* -* End of DORGBR -* - END diff --git a/ext/lapack/dorgl2.f b/ext/lapack/dorgl2.f deleted file mode 100644 index 76274955d..000000000 --- a/ext/lapack/dorgl2.f +++ /dev/null @@ -1,134 +0,0 @@ - SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORGL2 generates an m by n real matrix Q with orthonormal rows, -* which is defined as the first m rows of a product of k elementary -* reflectors of order n -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGELQF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. N >= M. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. M >= K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the i-th row must contain the vector which defines -* the elementary reflector H(i), for i = 1,2,...,k, as returned -* by DGELQF in the first k rows of its array argument A. -* On exit, the m-by-n matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGELQF. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (M) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, J, L -* .. -* .. External Subroutines .. - EXTERNAL DLARF, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.M ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGL2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 ) - $ RETURN -* - IF( K.LT.M ) THEN -* -* Initialise rows k+1:m to rows of the unit matrix -* - DO 20 J = 1, N - DO 10 L = K + 1, M - A( L, J ) = ZERO - 10 CONTINUE - IF( J.GT.K .AND. J.LE.M ) - $ A( J, J ) = ONE - 20 CONTINUE - END IF -* - DO 40 I = K, 1, -1 -* -* Apply H(i) to A(i:m,i:n) from the right -* - IF( I.LT.N ) THEN - IF( I.LT.M ) THEN - A( I, I ) = ONE - CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, - $ TAU( I ), A( I+1, I ), LDA, WORK ) - END IF - CALL DSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA ) - END IF - A( I, I ) = ONE - TAU( I ) -* -* Set A(1:i-1,i) to zero -* - DO 30 L = 1, I - 1 - A( I, L ) = ZERO - 30 CONTINUE - 40 CONTINUE - RETURN -* -* End of DORGL2 -* - END diff --git a/ext/lapack/dorglq.f b/ext/lapack/dorglq.f deleted file mode 100644 index a266be514..000000000 --- a/ext/lapack/dorglq.f +++ /dev/null @@ -1,207 +0,0 @@ - SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DORGLQ generates an M-by-N real matrix Q with orthonormal rows, -* which is defined as the first M rows of a product of K elementary -* reflectors of order N -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGELQF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. N >= M. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. M >= K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the i-th row must contain the vector which defines -* the elementary reflector H(i), for i = 1,2,...,k, as returned -* by DGELQF in the first k rows of its array argument A. -* On exit, the M-by-N matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGELQF. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,M). -* For optimum performance LWORK >= M*NB, where NB is -* the optimal blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORGL2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.M ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, M ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGLQ', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Determine the block size. -* - NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 ) - NBMIN = 2 - NX = 0 - IWS = M - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DORGLQ', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = M - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORGLQ', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the last block. -* The first kk rows are handled by the block method. -* - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) -* -* Set A(kk+1:m,1:kk) to zero. -* - DO 20 J = 1, KK - DO 10 I = KK + 1, M - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the last or only block. -* - IF( KK.LT.M ) - $ CALL DORGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, - $ TAU( KK+1 ), WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF( I+IB.LE.M ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ), - $ LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H' to A(i+ib:m,i:n) from the right -* - CALL DLARFB( 'Right', 'Transpose', 'Forward', 'Rowwise', - $ M-I-IB+1, N-I+1, IB, A( I, I ), LDA, WORK, - $ LDWORK, A( I+IB, I ), LDA, WORK( IB+1 ), - $ LDWORK ) - END IF -* -* Apply H' to columns i:n of current block -* - CALL DORGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* -* Set columns 1:i-1 of current block to zero -* - DO 40 J = 1, I - 1 - DO 30 L = I, I + IB - 1 - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DORGLQ -* - END diff --git a/ext/lapack/dorgqr.f b/ext/lapack/dorgqr.f deleted file mode 100644 index c16ac6d83..000000000 --- a/ext/lapack/dorgqr.f +++ /dev/null @@ -1,208 +0,0 @@ - SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INFO, K, LDA, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DORGQR generates an M-by-N real matrix Q with orthonormal columns, -* which is defined as the first N columns of a product of K elementary -* reflectors of order M -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. -* -* Arguments -* ========= -* -* M (input) INTEGER -* The number of rows of the matrix Q. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix Q. M >= N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines the -* matrix Q. N >= K >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the i-th column must contain the vector which -* defines the elementary reflector H(i), for i = 1,2,...,k, as -* returned by DGEQRF in the first k columns of its array -* argument A. -* On exit, the M-by-N matrix Q. -* -* LDA (input) INTEGER -* The first dimension of the array A. LDA >= max(1,M). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. LWORK >= max(1,N). -* For optimum performance LWORK >= N*NB, where NB is the -* optimal blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument has an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK, NB, - $ NBMIN, NX -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. External Functions .. - INTEGER ILAENV - EXTERNAL ILAENV -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - IF( M.LT.0 ) THEN - INFO = -1 - ELSE IF( N.LT.0 .OR. N.GT.M ) THEN - INFO = -2 - ELSE IF( K.LT.0 .OR. K.GT.N ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, M ) ) THEN - INFO = -5 - ELSE IF( LWORK.LT.MAX( 1, N ) ) THEN - INFO = -8 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORGQR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.LE.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Determine the block size. -* - NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 ) - NBMIN = 2 - NX = 0 - IWS = N - IF( NB.GT.1 .AND. NB.LT.K ) THEN -* -* Determine when to cross over from blocked to unblocked code. -* - NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) ) - IF( NX.LT.K ) THEN -* -* Determine if workspace is large enough for blocked code. -* - LDWORK = N - IWS = LDWORK*NB - IF( LWORK.LT.IWS ) THEN -* -* Not enough workspace to use optimal NB: reduce NB and -* determine the minimum value of NB. -* - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) ) - END IF - END IF - END IF -* - IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN -* -* Use blocked code after the last block. -* The first kk columns are handled by the block method. -* - KI = ( ( K-NX-1 ) / NB )*NB - KK = MIN( K, KI+NB ) -* -* Set A(1:kk,kk+1:n) to zero. -* - DO 20 J = KK + 1, N - DO 10 I = 1, KK - A( I, J ) = ZERO - 10 CONTINUE - 20 CONTINUE - ELSE - KK = 0 - END IF -* -* Use unblocked code for the last or only block. -* - IF( KK.LT.N ) - $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA, - $ TAU( KK+1 ), WORK, IINFO ) -* - IF( KK.GT.0 ) THEN -* -* Use blocked code -* - DO 50 I = KI + 1, 1, -NB - IB = MIN( NB, K-I+1 ) - IF( I+IB.LE.N ) THEN -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB, - $ A( I, I ), LDA, TAU( I ), WORK, LDWORK ) -* -* Apply H to A(i:m,i+ib:n) from the left -* - CALL DLARFB( 'Left', 'No transpose', 'Forward', - $ 'Columnwise', M-I+1, N-I-IB+1, IB, - $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ), - $ LDA, WORK( IB+1 ), LDWORK ) - END IF -* -* Apply H to rows i:m of current block -* - CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK, - $ IINFO ) -* -* Set rows 1:i-1 of current block to zero -* - DO 40 J = I, I + IB - 1 - DO 30 L = 1, I - 1 - A( L, J ) = ZERO - 30 CONTINUE - 40 CONTINUE - 50 CONTINUE - END IF -* - WORK( 1 ) = IWS - RETURN -* -* End of DORGQR -* - END diff --git a/ext/lapack/dorm2r.f b/ext/lapack/dorm2r.f deleted file mode 100644 index 74dd845ef..000000000 --- a/ext/lapack/dorm2r.f +++ /dev/null @@ -1,198 +0,0 @@ - SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORM2R overwrites the general real m by n matrix C with -* -* Q * C if SIDE = 'L' and TRANS = 'N', or -* -* Q'* C if SIDE = 'L' and TRANS = 'T', or -* -* C * Q if SIDE = 'R' and TRANS = 'N', or -* -* C * Q' if SIDE = 'R' and TRANS = 'T', -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q' from the Left -* = 'R': apply Q or Q' from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply Q (No transpose) -* = 'T': apply Q' (Transpose) -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGEQRF in the first k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* (N) if SIDE = 'L', -* (M) if SIDE = 'R' -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORM2R', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) ) - $ THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ), - $ LDC, WORK ) - A( I, I ) = AII - 10 CONTINUE - RETURN -* -* End of DORM2R -* - END diff --git a/ext/lapack/dormbr.f b/ext/lapack/dormbr.f deleted file mode 100644 index 5002fb511..000000000 --- a/ext/lapack/dormbr.f +++ /dev/null @@ -1,250 +0,0 @@ - SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C, - $ LDC, WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS, VECT - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), - $ WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C -* with -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'T': Q**T * C C * Q**T -* -* If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C -* with -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': P * C C * P -* TRANS = 'T': P**T * C C * P**T -* -* Here Q and P**T are the orthogonal matrices determined by DGEBRD when -* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and -* P**T are defined as products of elementary reflectors H(i) and G(i) -* respectively. -* -* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the -* order of the orthogonal matrix Q or P**T that is applied. -* -* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix: -* if nq >= k, Q = H(1) H(2) . . . H(k); -* if nq < k, Q = H(1) H(2) . . . H(nq-1). -* -* If VECT = 'P', A is assumed to have been a K-by-NQ matrix: -* if k < nq, P = G(1) G(2) . . . G(k); -* if k >= nq, P = G(1) G(2) . . . G(nq-1). -* -* Arguments -* ========= -* -* VECT (input) CHARACTER*1 -* = 'Q': apply Q or Q**T; -* = 'P': apply P or P**T. -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q, Q**T, P or P**T from the Left; -* = 'R': apply Q, Q**T, P or P**T from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q or P; -* = 'T': Transpose, apply Q**T or P**T. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* If VECT = 'Q', the number of columns in the original -* matrix reduced by DGEBRD. -* If VECT = 'P', the number of rows in the original -* matrix reduced by DGEBRD. -* K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension -* (LDA,min(nq,K)) if VECT = 'Q' -* (LDA,nq) if VECT = 'P' -* The vectors which define the elementary reflectors H(i) and -* G(i), whose products determine the matrices Q and P, as -* returned by DGEBRD. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If VECT = 'Q', LDA >= max(1,nq); -* if VECT = 'P', LDA >= max(1,min(nq,K)). -* -* TAU (input) DOUBLE PRECISION array, dimension (min(nq,K)) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i) or G(i) which determines Q or P, as returned -* by DGEBRD in the array argument TAUQ or TAUP. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q -* or P*C or P**T*C or C*P or C*P**T. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL APPLYQ, LEFT, NOTRAN - CHARACTER TRANST - INTEGER I1, I2, IINFO, MI, NI, NQ, NW -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DORMLQ, DORMQR, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - APPLYQ = LSAME( VECT, 'Q' ) - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q or P and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -3 - ELSE IF( M.LT.0 ) THEN - INFO = -4 - ELSE IF( N.LT.0 ) THEN - INFO = -5 - ELSE IF( K.LT.0 ) THEN - INFO = -6 - ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR. - $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) ) - $ THEN - INFO = -8 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -11 - ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN - INFO = -13 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMBR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - WORK( 1 ) = 1 - IF( M.EQ.0 .OR. N.EQ.0 ) - $ RETURN -* - IF( APPLYQ ) THEN -* -* Apply Q -* - IF( NQ.GE.K ) THEN -* -* Q was determined by a call to DGEBRD with nq >= k -* - CALL DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, IINFO ) - ELSE IF( NQ.GT.1 ) THEN -* -* Q was determined by a call to DGEBRD with nq < k -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - I1 = 2 - I2 = 1 - ELSE - MI = M - NI = N - 1 - I1 = 1 - I2 = 2 - END IF - CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, - $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - ELSE -* -* Apply P -* - IF( NOTRAN ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF - IF( NQ.GT.K ) THEN -* -* P was determined by a call to DGEBRD with nq > k -* - CALL DORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, IINFO ) - ELSE IF( NQ.GT.1 ) THEN -* -* P was determined by a call to DGEBRD with nq <= k -* - IF( LEFT ) THEN - MI = M - 1 - NI = N - I1 = 2 - I2 = 1 - ELSE - MI = M - NI = N - 1 - I1 = 1 - I2 = 2 - END IF - CALL DORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA, - $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO ) - END IF - END IF - RETURN -* -* End of DORMBR -* - END diff --git a/ext/lapack/dorml2.f b/ext/lapack/dorml2.f deleted file mode 100644 index bb789d864..000000000 --- a/ext/lapack/dorml2.f +++ /dev/null @@ -1,198 +0,0 @@ - SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DORML2 overwrites the general real m by n matrix C with -* -* Q * C if SIDE = 'L' and TRANS = 'N', or -* -* Q'* C if SIDE = 'L' and TRANS = 'T', or -* -* C * Q if SIDE = 'R' and TRANS = 'N', or -* -* C * Q' if SIDE = 'R' and TRANS = 'T', -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q' from the Left -* = 'R': apply Q or Q' from the Right -* -* TRANS (input) CHARACTER*1 -* = 'N': apply Q (No transpose) -* = 'T': apply Q' (Transpose) -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension -* (LDA,M) if SIDE = 'L', -* (LDA,N) if SIDE = 'R' -* The i-th row must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGELQF in the first k rows of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,K). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGELQF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the m by n matrix C. -* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace) DOUBLE PRECISION array, dimension -* (N) if SIDE = 'L', -* (M) if SIDE = 'R' -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ - DOUBLE PRECISION AII -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DLARF, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q -* - IF( LEFT ) THEN - NQ = M - ELSE - NQ = N - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORML2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) - $ RETURN -* - IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) - $ THEN - I1 = 1 - I2 = K - I3 = 1 - ELSE - I1 = K - I2 = 1 - I3 = -1 - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IF( LEFT ) THEN -* -* H(i) is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H(i) is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H(i) -* - AII = A( I, I ) - A( I, I ) = ONE - CALL DLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ), - $ C( IC, JC ), LDC, WORK ) - A( I, I ) = AII - 10 CONTINUE - RETURN -* -* End of DORML2 -* - END diff --git a/ext/lapack/dormlq.f b/ext/lapack/dormlq.f deleted file mode 100644 index cb5c9fae3..000000000 --- a/ext/lapack/dormlq.f +++ /dev/null @@ -1,254 +0,0 @@ - SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), - $ WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DORMLQ overwrites the general real M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'T': Q**T * C C * Q**T -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(k) . . . H(2) H(1) -* -* as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**T from the Left; -* = 'R': apply Q or Q**T from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'T': Transpose, apply Q**T. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension -* (LDA,M) if SIDE = 'L', -* (LDA,N) if SIDE = 'R' -* The i-th row must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGELQF in the first k rows of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,K). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGELQF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - CHARACTER TRANST - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ MI, NB, NBMIN, NI, NQ, NW -* .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORML2, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, K ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN - INFO = -12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMLQ', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K, - $ -1 ) ) - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - ELSE - IWS = NW - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IF( ( LEFT .AND. NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - IF( NOTRAN ) THEN - TRANST = 'T' - ELSE - TRANST = 'N' - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), T, LDT ) - IF( LEFT ) THEN -* -* H or H' is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H' is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H' -* - CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB, - $ A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, WORK, - $ LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = IWS - RETURN -* -* End of DORMLQ -* - END diff --git a/ext/lapack/dormqr.f b/ext/lapack/dormqr.f deleted file mode 100644 index 0700bcdbf..000000000 --- a/ext/lapack/dormqr.f +++ /dev/null @@ -1,247 +0,0 @@ - SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, - $ WORK, LWORK, INFO ) -* -* -- LAPACK routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER SIDE, TRANS - INTEGER INFO, K, LDA, LDC, LWORK, M, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), - $ WORK( LWORK ) -* .. -* -* Purpose -* ======= -* -* DORMQR overwrites the general real M-by-N matrix C with -* -* SIDE = 'L' SIDE = 'R' -* TRANS = 'N': Q * C C * Q -* TRANS = 'T': Q**T * C C * Q**T -* -* where Q is a real orthogonal matrix defined as the product of k -* elementary reflectors -* -* Q = H(1) H(2) . . . H(k) -* -* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N -* if SIDE = 'R'. -* -* Arguments -* ========= -* -* SIDE (input) CHARACTER*1 -* = 'L': apply Q or Q**T from the Left; -* = 'R': apply Q or Q**T from the Right. -* -* TRANS (input) CHARACTER*1 -* = 'N': No transpose, apply Q; -* = 'T': Transpose, apply Q**T. -* -* M (input) INTEGER -* The number of rows of the matrix C. M >= 0. -* -* N (input) INTEGER -* The number of columns of the matrix C. N >= 0. -* -* K (input) INTEGER -* The number of elementary reflectors whose product defines -* the matrix Q. -* If SIDE = 'L', M >= K >= 0; -* if SIDE = 'R', N >= K >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,K) -* The i-th column must contain the vector which defines the -* elementary reflector H(i), for i = 1,2,...,k, as returned by -* DGEQRF in the first k columns of its array argument A. -* A is modified by the routine but restored on exit. -* -* LDA (input) INTEGER -* The leading dimension of the array A. -* If SIDE = 'L', LDA >= max(1,M); -* if SIDE = 'R', LDA >= max(1,N). -* -* TAU (input) DOUBLE PRECISION array, dimension (K) -* TAU(i) must contain the scalar factor of the elementary -* reflector H(i), as returned by DGEQRF. -* -* C (input/output) DOUBLE PRECISION array, dimension (LDC,N) -* On entry, the M-by-N matrix C. -* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. -* -* LDC (input) INTEGER -* The leading dimension of the array C. LDC >= max(1,M). -* -* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK) -* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. -* -* LWORK (input) INTEGER -* The dimension of the array WORK. -* If SIDE = 'L', LWORK >= max(1,N); -* if SIDE = 'R', LWORK >= max(1,M). -* For optimum performance LWORK >= N*NB if SIDE = 'L', and -* LWORK >= M*NB if SIDE = 'R', where NB is the optimal -* blocksize. -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - INTEGER NBMAX, LDT - PARAMETER ( NBMAX = 64, LDT = NBMAX+1 ) -* .. -* .. Local Scalars .. - LOGICAL LEFT, NOTRAN - INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK, - $ MI, NB, NBMIN, NI, NQ, NW -* .. -* .. Local Arrays .. - DOUBLE PRECISION T( LDT, NBMAX ) -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input arguments -* - INFO = 0 - LEFT = LSAME( SIDE, 'L' ) - NOTRAN = LSAME( TRANS, 'N' ) -* -* NQ is the order of Q and NW is the minimum dimension of WORK -* - IF( LEFT ) THEN - NQ = M - NW = N - ELSE - NQ = N - NW = M - END IF - IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN - INFO = -1 - ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN - INFO = -2 - ELSE IF( M.LT.0 ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN - INFO = -7 - ELSE IF( LDC.LT.MAX( 1, M ) ) THEN - INFO = -10 - ELSE IF( LWORK.LT.MAX( 1, NW ) ) THEN - INFO = -12 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DORMQR', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN - WORK( 1 ) = 1 - RETURN - END IF -* -* Determine the block size. NB may be at most NBMAX, where NBMAX -* is used to define the local array T. -* - NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - NBMIN = 2 - LDWORK = NW - IF( NB.GT.1 .AND. NB.LT.K ) THEN - IWS = NW*NB - IF( LWORK.LT.IWS ) THEN - NB = LWORK / LDWORK - NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K, - $ -1 ) ) - END IF - ELSE - IWS = NW - END IF -* - IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN -* -* Use unblocked code -* - CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, - $ IINFO ) - ELSE -* -* Use blocked code -* - IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. - $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN - I1 = 1 - I2 = K - I3 = NB - ELSE - I1 = ( ( K-1 ) / NB )*NB + 1 - I2 = 1 - I3 = -NB - END IF -* - IF( LEFT ) THEN - NI = N - JC = 1 - ELSE - MI = M - IC = 1 - END IF -* - DO 10 I = I1, I2, I3 - IB = MIN( NB, K-I+1 ) -* -* Form the triangular factor of the block reflector -* H = H(i) H(i+1) . . . H(i+ib-1) -* - CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ), - $ LDA, TAU( I ), T, LDT ) - IF( LEFT ) THEN -* -* H or H' is applied to C(i:m,1:n) -* - MI = M - I + 1 - IC = I - ELSE -* -* H or H' is applied to C(1:m,i:n) -* - NI = N - I + 1 - JC = I - END IF -* -* Apply H or H' -* - CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI, - $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, - $ WORK, LDWORK ) - 10 CONTINUE - END IF - WORK( 1 ) = IWS - RETURN -* -* End of DORMQR -* - END diff --git a/ext/lapack/dpotf2.f b/ext/lapack/dpotf2.f deleted file mode 100644 index f9e0de06e..000000000 --- a/ext/lapack/dpotf2.f +++ /dev/null @@ -1,168 +0,0 @@ - SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* February 29, 1992 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DPOTF2 computes the Cholesky factorization of a real symmetric -* positive definite matrix A. -* -* The factorization has the form -* A = U' * U , if UPLO = 'U', or -* A = L * L', if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the unblocked version of the algorithm, calling Level 2 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* Specifies whether the upper or lower triangular part of the -* symmetric matrix A is stored. -* = 'U': Upper triangular -* = 'L': Lower triangular -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* n by n upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading n by n lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U'*U or A = L*L'. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -k, the k-th argument had an illegal value -* > 0: if INFO = k, the leading minor of order k is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J - DOUBLE PRECISION AJJ -* .. -* .. External Functions .. - LOGICAL LSAME - DOUBLE PRECISION DDOT - EXTERNAL LSAME, DDOT -* .. -* .. External Subroutines .. - EXTERNAL DGEMV, DSCAL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, SQRT -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTF2', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N -* -* Compute U(J,J) and test for non-positive-definiteness. -* - AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 ) - IF( AJJ.LE.ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of row J. -* - IF( J.LT.N ) THEN - CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ), - $ LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA ) - CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA ) - END IF - 10 CONTINUE - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N -* -* Compute L(J,J) and test for non-positive-definiteness. -* - AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ), - $ LDA ) - IF( AJJ.LE.ZERO ) THEN - A( J, J ) = AJJ - GO TO 30 - END IF - AJJ = SQRT( AJJ ) - A( J, J ) = AJJ -* -* Compute elements J+1:N of column J. -* - IF( J.LT.N ) THEN - CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ), - $ LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 ) - CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 ) - END IF - 20 CONTINUE - END IF - GO TO 40 -* - 30 CONTINUE - INFO = J -* - 40 CONTINUE - RETURN -* -* End of DPOTF2 -* - END diff --git a/ext/lapack/dpotrf.f b/ext/lapack/dpotrf.f deleted file mode 100644 index c4b0cb459..000000000 --- a/ext/lapack/dpotrf.f +++ /dev/null @@ -1,184 +0,0 @@ - SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, N -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ) -* .. -* -* Purpose -* ======= -* -* DPOTRF computes the Cholesky factorization of a real symmetric -* positive definite matrix A. -* -* The factorization has the form -* A = U**T * U, if UPLO = 'U', or -* A = L * L**T, if UPLO = 'L', -* where U is an upper triangular matrix and L is lower triangular. -* -* This is the block version of the algorithm, calling Level 3 BLAS. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, the symmetric matrix A. If UPLO = 'U', the leading -* N-by-N upper triangular part of A contains the upper -* triangular part of the matrix A, and the strictly lower -* triangular part of A is not referenced. If UPLO = 'L', the -* leading N-by-N lower triangular part of A contains the lower -* triangular part of the matrix A, and the strictly upper -* triangular part of A is not referenced. -* -* On exit, if INFO = 0, the factor U or L from the Cholesky -* factorization A = U**T*U or A = L*L**T. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the leading minor of order i is not -* positive definite, and the factorization could not be -* completed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER - INTEGER J, JB, NB -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER ILAENV - EXTERNAL LSAME, ILAENV -* .. -* .. External Subroutines .. - EXTERNAL DGEMM, DPOTF2, DSYRK, DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX, MIN -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -4 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRF', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Determine the block size for this environment. -* - NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 ) - IF( NB.LE.1 .OR. NB.GE.N ) THEN -* -* Use unblocked code. -* - CALL DPOTF2( UPLO, N, A, LDA, INFO ) - ELSE -* -* Use blocked code. -* - IF( UPPER ) THEN -* -* Compute the Cholesky factorization A = U'*U. -* - DO 10 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE, - $ A( 1, J ), LDA, ONE, A( J, J ), LDA ) - CALL DPOTF2( 'Upper', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block row. -* - CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1, - $ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ), - $ LDA, ONE, A( J, J+JB ), LDA ) - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', - $ JB, N-J-JB+1, ONE, A( J, J ), LDA, - $ A( J, J+JB ), LDA ) - END IF - 10 CONTINUE -* - ELSE -* -* Compute the Cholesky factorization A = L*L'. -* - DO 20 J = 1, N, NB -* -* Update and factorize the current diagonal block and test -* for non-positive-definiteness. -* - JB = MIN( NB, N-J+1 ) - CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE, - $ A( J, 1 ), LDA, ONE, A( J, J ), LDA ) - CALL DPOTF2( 'Lower', JB, A( J, J ), LDA, INFO ) - IF( INFO.NE.0 ) - $ GO TO 30 - IF( J+JB.LE.N ) THEN -* -* Compute the current block column. -* - CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB, - $ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ), - $ LDA, ONE, A( J+JB, J ), LDA ) - CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit', - $ N-J-JB+1, JB, ONE, A( J, J ), LDA, - $ A( J+JB, J ), LDA ) - END IF - 20 CONTINUE - END IF - END IF - GO TO 40 -* - 30 CONTINUE - INFO = INFO + J - 1 -* - 40 CONTINUE - RETURN -* -* End of DPOTRF -* - END diff --git a/ext/lapack/dpotrs.f b/ext/lapack/dpotrs.f deleted file mode 100644 index ae3ab2f31..000000000 --- a/ext/lapack/dpotrs.f +++ /dev/null @@ -1,133 +0,0 @@ - SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER UPLO - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DPOTRS solves a system of linear equations A*X = B with a symmetric -* positive definite matrix A using the Cholesky factorization -* A = U**T*U or A = L*L**T computed by DPOTRF. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': Upper triangle of A is stored; -* = 'L': Lower triangle of A is stored. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The triangular factor U or L from the Cholesky factorization -* A = U**T*U or A = L*L**T, as computed by DPOTRF. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL UPPER -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( N.LT.0 ) THEN - INFO = -2 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -3 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -5 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -7 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DPOTRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 .OR. NRHS.EQ.0 ) - $ RETURN -* - IF( UPPER ) THEN -* -* Solve A*X = B where A = U'*U. -* -* Solve U'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) -* -* Solve U*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) - ELSE -* -* Solve A*X = B where A = L*L'. -* -* Solve L*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N, - $ NRHS, ONE, A, LDA, B, LDB ) -* -* Solve L'*X = B, overwriting B with X. -* - CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS, - $ ONE, A, LDA, B, LDB ) - END IF -* - RETURN -* -* End of DPOTRS -* - END diff --git a/ext/lapack/drscl.f b/ext/lapack/drscl.f deleted file mode 100644 index 00628b300..000000000 --- a/ext/lapack/drscl.f +++ /dev/null @@ -1,115 +0,0 @@ - SUBROUTINE DRSCL( N, SA, SX, INCX ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - INTEGER INCX, N - DOUBLE PRECISION SA -* .. -* .. Array Arguments .. - DOUBLE PRECISION SX( * ) -* .. -* -* Purpose -* ======= -* -* DRSCL multiplies an n-element real vector x by the real scalar 1/a. -* This is done without overflow or underflow as long as -* the final result x/a does not overflow or underflow. -* -* Arguments -* ========= -* -* N (input) INTEGER -* The number of components of the vector x. -* -* SA (input) DOUBLE PRECISION -* The scalar a which is used to divide each component of x. -* SA must be >= 0, or the subroutine will divide by zero. -* -* SX (input/output) DOUBLE PRECISION array, dimension -* (1+(N-1)*abs(INCX)) -* The n-element vector x. -* -* INCX (input) INTEGER -* The increment between successive values of the vector SX. -* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL DONE - DOUBLE PRECISION BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM -* .. -* .. External Functions .. - DOUBLE PRECISION DLAMCH - EXTERNAL DLAMCH -* .. -* .. External Subroutines .. - EXTERNAL DLABAD, DSCAL -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS -* .. -* .. Executable Statements .. -* -* Quick return if possible -* - IF( N.LE.0 ) - $ RETURN -* -* Get machine parameters -* - SMLNUM = DLAMCH( 'S' ) - BIGNUM = ONE / SMLNUM - CALL DLABAD( SMLNUM, BIGNUM ) -* -* Initialize the denominator to SA and the numerator to 1. -* - CDEN = SA - CNUM = ONE -* - 10 CONTINUE - CDEN1 = CDEN*SMLNUM - CNUM1 = CNUM / BIGNUM - IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN -* -* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. -* - MUL = SMLNUM - DONE = .FALSE. - CDEN = CDEN1 - ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN -* -* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. -* - MUL = BIGNUM - DONE = .FALSE. - CNUM = CNUM1 - ELSE -* -* Multiply X by CNUM / CDEN and return. -* - MUL = CNUM / CDEN - DONE = .TRUE. - END IF -* -* Scale the vector X by MUL -* - CALL DSCAL( N, MUL, SX, INCX ) -* - IF( .NOT.DONE ) - $ GO TO 10 -* - RETURN -* -* End of DRSCL -* - END diff --git a/ext/lapack/dtrcon.f b/ext/lapack/dtrcon.f deleted file mode 100644 index 8da58c760..000000000 --- a/ext/lapack/dtrcon.f +++ /dev/null @@ -1,193 +0,0 @@ - SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, - $ IWORK, INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER DIAG, NORM, UPLO - INTEGER INFO, LDA, N - DOUBLE PRECISION RCOND -* .. -* .. Array Arguments .. - INTEGER IWORK( * ) - DOUBLE PRECISION A( LDA, * ), WORK( * ) -* .. -* -* Purpose -* ======= -* -* DTRCON estimates the reciprocal of the condition number of a -* triangular matrix A, in either the 1-norm or the infinity-norm. -* -* The norm of A is computed and an estimate is obtained for -* norm(inv(A)), then the reciprocal of the condition number is -* computed as -* RCOND = 1 / ( norm(A) * norm(inv(A)) ). -* -* Arguments -* ========= -* -* NORM (input) CHARACTER*1 -* Specifies whether the 1-norm condition number or the -* infinity-norm condition number is required: -* = '1' or 'O': 1-norm; -* = 'I': Infinity-norm. -* -* UPLO (input) CHARACTER*1 -* = 'U': A is upper triangular; -* = 'L': A is lower triangular. -* -* DIAG (input) CHARACTER*1 -* = 'N': A is non-unit triangular; -* = 'U': A is unit triangular. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The triangular matrix A. If UPLO = 'U', the leading N-by-N -* upper triangular part of the array A contains the upper -* triangular matrix, and the strictly lower triangular part of -* A is not referenced. If UPLO = 'L', the leading N-by-N lower -* triangular part of the array A contains the lower triangular -* matrix, and the strictly upper triangular part of A is not -* referenced. If DIAG = 'U', the diagonal elements of A are -* also not referenced and are assumed to be 1. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* RCOND (output) DOUBLE PRECISION -* The reciprocal of the condition number of the matrix A, -* computed as RCOND = 1/(norm(A) * norm(inv(A))). -* -* WORK (workspace) DOUBLE PRECISION array, dimension (3*N) -* -* IWORK (workspace) INTEGER array, dimension (N) -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ONE, ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT, ONENRM, UPPER - CHARACTER NORMIN - INTEGER IX, KASE, KASE1 - DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM -* .. -* .. External Functions .. - LOGICAL LSAME - INTEGER IDAMAX - DOUBLE PRECISION DLAMCH, DLANTR - EXTERNAL LSAME, IDAMAX, DLAMCH, DLANTR -* .. -* .. External Subroutines .. - EXTERNAL DLACON, DLATRS, DRSCL, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC ABS, DBLE, MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - UPPER = LSAME( UPLO, 'U' ) - ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' ) - NOUNIT = LSAME( DIAG, 'N' ) -* - IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN - INFO = -1 - ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -6 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRCON', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) THEN - RCOND = ONE - RETURN - END IF -* - RCOND = ZERO - SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) ) -* -* Compute the norm of the triangular matrix A. -* - ANORM = DLANTR( NORM, UPLO, DIAG, N, N, A, LDA, WORK ) -* -* Continue only if ANORM > 0. -* - IF( ANORM.GT.ZERO ) THEN -* -* Estimate the norm of the inverse of A. -* - AINVNM = ZERO - NORMIN = 'N' - IF( ONENRM ) THEN - KASE1 = 1 - ELSE - KASE1 = 2 - END IF - KASE = 0 - 10 CONTINUE - CALL DLACON( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE ) - IF( KASE.NE.0 ) THEN - IF( KASE.EQ.KASE1 ) THEN -* -* Multiply by inv(A). -* - CALL DLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A, - $ LDA, WORK, SCALE, WORK( 2*N+1 ), INFO ) - ELSE -* -* Multiply by inv(A'). -* - CALL DLATRS( UPLO, 'Transpose', DIAG, NORMIN, N, A, LDA, - $ WORK, SCALE, WORK( 2*N+1 ), INFO ) - END IF - NORMIN = 'Y' -* -* Multiply by 1/SCALE if doing so will not cause overflow. -* - IF( SCALE.NE.ONE ) THEN - IX = IDAMAX( N, WORK, 1 ) - XNORM = ABS( WORK( IX ) ) - IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO ) - $ GO TO 20 - CALL DRSCL( N, SCALE, WORK, 1 ) - END IF - GO TO 10 - END IF -* -* Compute the estimate of the reciprocal condition number. -* - IF( AINVNM.NE.ZERO ) - $ RCOND = ( ONE / ANORM ) / AINVNM - END IF -* - 20 CONTINUE - RETURN -* -* End of DTRCON -* - END diff --git a/ext/lapack/dtrtrs.f b/ext/lapack/dtrtrs.f deleted file mode 100644 index c1b4c5c4c..000000000 --- a/ext/lapack/dtrtrs.f +++ /dev/null @@ -1,148 +0,0 @@ - SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, - $ INFO ) -* -* -- LAPACK routine (version 3.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* March 31, 1993 -* -* .. Scalar Arguments .. - CHARACTER DIAG, TRANS, UPLO - INTEGER INFO, LDA, LDB, N, NRHS -* .. -* .. Array Arguments .. - DOUBLE PRECISION A( LDA, * ), B( LDB, * ) -* .. -* -* Purpose -* ======= -* -* DTRTRS solves a triangular system of the form -* -* A * X = B or A**T * X = B, -* -* where A is a triangular matrix of order N, and B is an N-by-NRHS -* matrix. A check is made to verify that A is nonsingular. -* -* Arguments -* ========= -* -* UPLO (input) CHARACTER*1 -* = 'U': A is upper triangular; -* = 'L': A is lower triangular. -* -* TRANS (input) CHARACTER*1 -* Specifies the form of the system of equations: -* = 'N': A * X = B (No transpose) -* = 'T': A**T * X = B (Transpose) -* = 'C': A**H * X = B (Conjugate transpose = Transpose) -* -* DIAG (input) CHARACTER*1 -* = 'N': A is non-unit triangular; -* = 'U': A is unit triangular. -* -* N (input) INTEGER -* The order of the matrix A. N >= 0. -* -* NRHS (input) INTEGER -* The number of right hand sides, i.e., the number of columns -* of the matrix B. NRHS >= 0. -* -* A (input) DOUBLE PRECISION array, dimension (LDA,N) -* The triangular matrix A. If UPLO = 'U', the leading N-by-N -* upper triangular part of the array A contains the upper -* triangular matrix, and the strictly lower triangular part of -* A is not referenced. If UPLO = 'L', the leading N-by-N lower -* triangular part of the array A contains the lower triangular -* matrix, and the strictly upper triangular part of A is not -* referenced. If DIAG = 'U', the diagonal elements of A are -* also not referenced and are assumed to be 1. -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,N). -* -* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) -* On entry, the right hand side matrix B. -* On exit, if INFO = 0, the solution matrix X. -* -* LDB (input) INTEGER -* The leading dimension of the array B. LDB >= max(1,N). -* -* INFO (output) INTEGER -* = 0: successful exit -* < 0: if INFO = -i, the i-th argument had an illegal value -* > 0: if INFO = i, the i-th diagonal element of A is zero, -* indicating that the matrix is singular and the solutions -* X have not been computed. -* -* ===================================================================== -* -* .. Parameters .. - DOUBLE PRECISION ZERO, ONE - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) -* .. -* .. Local Scalars .. - LOGICAL NOUNIT -* .. -* .. External Functions .. - LOGICAL LSAME - EXTERNAL LSAME -* .. -* .. External Subroutines .. - EXTERNAL DTRSM, XERBLA -* .. -* .. Intrinsic Functions .. - INTRINSIC MAX -* .. -* .. Executable Statements .. -* -* Test the input parameters. -* - INFO = 0 - NOUNIT = LSAME( DIAG, 'N' ) - IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN - INFO = -1 - ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT. - $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN - INFO = -2 - ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN - INFO = -3 - ELSE IF( N.LT.0 ) THEN - INFO = -4 - ELSE IF( NRHS.LT.0 ) THEN - INFO = -5 - ELSE IF( LDA.LT.MAX( 1, N ) ) THEN - INFO = -7 - ELSE IF( LDB.LT.MAX( 1, N ) ) THEN - INFO = -9 - END IF - IF( INFO.NE.0 ) THEN - CALL XERBLA( 'DTRTRS', -INFO ) - RETURN - END IF -* -* Quick return if possible -* - IF( N.EQ.0 ) - $ RETURN -* -* Check for singularity. -* - IF( NOUNIT ) THEN - DO 10 INFO = 1, N - IF( A( INFO, INFO ).EQ.ZERO ) - $ RETURN - 10 CONTINUE - END IF - INFO = 0 -* -* Solve A * x = b or A' * x = b. -* - CALL DTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B, - $ LDB ) -* - RETURN -* -* End of DTRTRS -* - END diff --git a/ext/lapack/ilaenv.f b/ext/lapack/ilaenv.f deleted file mode 100644 index e3d296a88..000000000 --- a/ext/lapack/ilaenv.f +++ /dev/null @@ -1,506 +0,0 @@ - INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, - $ N4 ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER*( * ) NAME, OPTS - INTEGER ISPEC, N1, N2, N3, N4 -* .. -* -* Purpose -* ======= -* -* ILAENV is called from the LAPACK routines to choose problem-dependent -* parameters for the local environment. See ISPEC for a description of -* the parameters. -* -* This version provides a set of parameters which should give good, -* but not optimal, performance on many of the currently available -* computers. Users are encouraged to modify this subroutine to set -* the tuning parameters for their particular machine using the option -* and problem size information in the arguments. -* -* This routine will not function correctly if it is converted to all -* lower case. Converting it to all upper case is allowed. -* -* Arguments -* ========= -* -* ISPEC (input) INTEGER -* Specifies the parameter to be returned as the value of -* ILAENV. -* = 1: the optimal blocksize; if this value is 1, an unblocked -* algorithm will give the best performance. -* = 2: the minimum block size for which the block routine -* should be used; if the usable block size is less than -* this value, an unblocked routine should be used. -* = 3: the crossover point (in a block routine, for N less -* than this value, an unblocked routine should be used) -* = 4: the number of shifts, used in the nonsymmetric -* eigenvalue routines -* = 5: the minimum column dimension for blocking to be used; -* rectangular blocks must have dimension at least k by m, -* where k is given by ILAENV(2,...) and m by ILAENV(5,...) -* = 6: the crossover point for the SVD (when reducing an m by n -* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds -* this value, a QR factorization is used first to reduce -* the matrix to a triangular form.) -* = 7: the number of processors -* = 8: the crossover point for the multishift QR and QZ methods -* for nonsymmetric eigenvalue problems. -* -* NAME (input) CHARACTER*(*) -* The name of the calling subroutine, in either upper case or -* lower case. -* -* OPTS (input) CHARACTER*(*) -* The character options to the subroutine NAME, concatenated -* into a single character string. For example, UPLO = 'U', -* TRANS = 'T', and DIAG = 'N' for a triangular routine would -* be specified as OPTS = 'UTN'. -* -* N1 (input) INTEGER -* N2 (input) INTEGER -* N3 (input) INTEGER -* N4 (input) INTEGER -* Problem dimensions for the subroutine NAME; these may not all -* be required. -* -* (ILAENV) (output) INTEGER -* >= 0: the value of the parameter specified by ISPEC -* < 0: if ILAENV = -k, the k-th argument had an illegal value. -* -* Further Details -* =============== -* -* The following conventions have been used when calling ILAENV from the -* LAPACK routines: -* 1) OPTS is a concatenation of all of the character options to -* subroutine NAME, in the same order that they appear in the -* argument list for NAME, even if they are not used in determining -* the value of the parameter specified by ISPEC. -* 2) The problem dimensions N1, N2, N3, N4 are specified in the order -* that they appear in the argument list for NAME. N1 is used -* first, N2 second, and so on, and unused problem dimensions are -* passed a value of -1. -* 3) The parameter value returned by ILAENV is checked for validity in -* the calling subroutine. For example, ILAENV is used to retrieve -* the optimal blocksize for STRTRI as follows: -* -* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) -* IF( NB.LE.1 ) NB = MAX( 1, N ) -* -* ===================================================================== -* -* .. Local Scalars .. - LOGICAL CNAME, SNAME - CHARACTER*1 C1 - CHARACTER*2 C2, C4 - CHARACTER*3 C3 - CHARACTER*6 SUBNAM - INTEGER I, IC, IZ, NB, NBMIN, NX -* .. -* .. Intrinsic Functions .. - INTRINSIC CHAR, ICHAR, INT, MIN, REAL -* .. -* .. Executable Statements .. -* - GO TO ( 100, 100, 100, 400, 500, 600, 700, 800 ) ISPEC -* -* Invalid value for ISPEC -* - ILAENV = -1 - RETURN -* - 100 CONTINUE -* -* Convert NAME to upper case if the first character is lower case. -* - ILAENV = 1 - SUBNAM = NAME - IC = ICHAR( SUBNAM( 1:1 ) ) - IZ = ICHAR( 'Z' ) - IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN -* -* ASCII character set -* - IF( IC.GE.97 .AND. IC.LE.122 ) THEN - SUBNAM( 1:1 ) = CHAR( IC-32 ) - DO 10 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF( IC.GE.97 .AND. IC.LE.122 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 10 CONTINUE - END IF -* - ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN -* -* EBCDIC character set -* - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN - SUBNAM( 1:1 ) = CHAR( IC+64 ) - DO 20 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR. - $ ( IC.GE.145 .AND. IC.LE.153 ) .OR. - $ ( IC.GE.162 .AND. IC.LE.169 ) ) - $ SUBNAM( I:I ) = CHAR( IC+64 ) - 20 CONTINUE - END IF -* - ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN -* -* Prime machines: ASCII+128 -* - IF( IC.GE.225 .AND. IC.LE.250 ) THEN - SUBNAM( 1:1 ) = CHAR( IC-32 ) - DO 30 I = 2, 6 - IC = ICHAR( SUBNAM( I:I ) ) - IF( IC.GE.225 .AND. IC.LE.250 ) - $ SUBNAM( I:I ) = CHAR( IC-32 ) - 30 CONTINUE - END IF - END IF -* - C1 = SUBNAM( 1:1 ) - SNAME = C1.EQ.'S' .OR. C1.EQ.'D' - CNAME = C1.EQ.'C' .OR. C1.EQ.'Z' - IF( .NOT.( CNAME .OR. SNAME ) ) - $ RETURN - C2 = SUBNAM( 2:3 ) - C3 = SUBNAM( 4:6 ) - C4 = C3( 2:3 ) -* - GO TO ( 110, 200, 300 ) ISPEC -* - 110 CONTINUE -* -* ISPEC = 1: block size -* -* In these examples, separate code is provided for setting NB for -* real and complex. We assume that NB will take the same value in -* single or double precision. -* - NB = 1 -* - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NB = 32 - ELSE - NB = 32 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'PO' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NB = 1 - ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRF' ) THEN - NB = 64 - ELSE IF( C3.EQ.'TRD' ) THEN - NB = 1 - ELSE IF( C3.EQ.'GST' ) THEN - NB = 64 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NB = 32 - END IF - END IF - ELSE IF( C2.EQ.'GB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N4.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'PB' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - ELSE - IF( N2.LE.64 ) THEN - NB = 1 - ELSE - NB = 32 - END IF - END IF - END IF - ELSE IF( C2.EQ.'TR' ) THEN - IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( C2.EQ.'LA' ) THEN - IF( C3.EQ.'UUM' ) THEN - IF( SNAME ) THEN - NB = 64 - ELSE - NB = 64 - END IF - END IF - ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN - IF( C3.EQ.'EBZ' ) THEN - NB = 1 - END IF - END IF - ILAENV = NB - RETURN -* - 200 CONTINUE -* -* ISPEC = 2: minimum block size -* - NBMIN = 2 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - ELSE IF( C3.EQ.'TRI' ) THEN - IF( SNAME ) THEN - NBMIN = 2 - ELSE - NBMIN = 2 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( C3.EQ.'TRF' ) THEN - IF( SNAME ) THEN - NBMIN = 8 - ELSE - NBMIN = 8 - END IF - ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NBMIN = 2 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - ELSE IF( C3( 1:1 ).EQ.'M' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NBMIN = 2 - END IF - END IF - END IF - ILAENV = NBMIN - RETURN -* - 300 CONTINUE -* -* ISPEC = 3: crossover point -* - NX = 0 - IF( C2.EQ.'GE' ) THEN - IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. - $ C3.EQ.'QLF' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'HRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - ELSE IF( C3.EQ.'BRD' ) THEN - IF( SNAME ) THEN - NX = 128 - ELSE - NX = 128 - END IF - END IF - ELSE IF( C2.EQ.'SY' ) THEN - IF( SNAME .AND. C3.EQ.'TRD' ) THEN - NX = 1 - END IF - ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN - IF( C3.EQ.'TRD' ) THEN - NX = 1 - END IF - ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NX = 128 - END IF - END IF - ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN - IF( C3( 1:1 ).EQ.'G' ) THEN - IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. - $ C4.EQ.'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. - $ C4.EQ.'BR' ) THEN - NX = 128 - END IF - END IF - END IF - ILAENV = NX - RETURN -* - 400 CONTINUE -* -* ISPEC = 4: number of shifts (used by xHSEQR) -* - ILAENV = 6 - RETURN -* - 500 CONTINUE -* -* ISPEC = 5: minimum column dimension (not used) -* - ILAENV = 2 - RETURN -* - 600 CONTINUE -* -* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) -* - ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 ) - RETURN -* - 700 CONTINUE -* -* ISPEC = 7: number of processors (not used) -* - ILAENV = 1 - RETURN -* - 800 CONTINUE -* -* ISPEC = 8: crossover point for multishift (used by xHSEQR) -* - ILAENV = 50 - RETURN -* -* End of ILAENV -* - END diff --git a/ext/lapack/lsame.f b/ext/lapack/lsame.f deleted file mode 100644 index db133b544..000000000 --- a/ext/lapack/lsame.f +++ /dev/null @@ -1,87 +0,0 @@ - LOGICAL FUNCTION LSAME( CA, CB ) -* -* -- LAPACK auxiliary routine (version 2.0) -- -* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., -* Courant Institute, Argonne National Lab, and Rice University -* September 30, 1994 -* -* .. Scalar Arguments .. - CHARACTER CA, CB -* .. -* -* Purpose -* ======= -* -* LSAME returns .TRUE. if CA is the same letter as CB regardless of -* case. -* -* Arguments -* ========= -* -* CA (input) CHARACTER*1 -* CB (input) CHARACTER*1 -* CA and CB specify the single characters to be compared. -* -* ===================================================================== -* -* .. Intrinsic Functions .. - INTRINSIC ICHAR -* .. -* .. Local Scalars .. - INTEGER INTA, INTB, ZCODE -* .. -* .. Executable Statements .. -* -* Test if the characters are equal -* - LSAME = CA.EQ.CB - IF( LSAME ) - $ RETURN -* -* Now test for equivalence if both characters are alphabetic. -* - ZCODE = ICHAR( 'Z' ) -* -* Use 'Z' rather than 'A' so that ASCII can be detected on Prime -* machines, on which ICHAR returns a value with bit 8 set. -* ICHAR('A') on Prime machines returns 193 which is the same as -* ICHAR('A') on an EBCDIC machine. -* - INTA = ICHAR( CA ) - INTB = ICHAR( CB ) -* - IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN -* -* ASCII is assumed - ZCODE is the ASCII code of either lower or -* upper case 'Z'. -* - IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 - IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 -* - ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN -* -* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or -* upper case 'Z'. -* - IF( INTA.GE.129 .AND. INTA.LE.137 .OR. - $ INTA.GE.145 .AND. INTA.LE.153 .OR. - $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 - IF( INTB.GE.129 .AND. INTB.LE.137 .OR. - $ INTB.GE.145 .AND. INTB.LE.153 .OR. - $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 -* - ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN -* -* ASCII is assumed, on Prime machines - ZCODE is the ASCII code -* plus 128 of either lower or upper case 'Z'. -* - IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 - IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 - END IF - LSAME = INTA.EQ.INTB -* -* RETURN -* -* End of LSAME -* - END diff --git a/ext/math/daux.f b/ext/math/daux.f deleted file mode 100644 index f7bf84927..000000000 --- a/ext/math/daux.f +++ /dev/null @@ -1,257 +0,0 @@ -c DOUBLE PRECISION FUNCTION D1MACH (IDUM) -c INTEGER IDUM -cC----------------------------------------------------------------------- -cC THIS ROUTINE COMPUTES THE UNIT ROUNDOFF OF THE MACHINE IN DOUBLE -cC PRECISION. THIS IS DEFINED AS THE SMALLEST POSITIVE MACHINE NUMBER -cC U SUCH THAT 1.0D0 + U .NE. 1.0D0 (IN DOUBLE PRECISION). -cC----------------------------------------------------------------------- -c DOUBLE PRECISION U, COMP -c U = 1.0D0 -c 10 U = U*0.5D0 -c COMP = 1.0D0 + U -c IF (COMP .NE. 1.0D0) GO TO 10 -c D1MACH = U*2.0D0 -c RETURN -cC----------------------- END OF FUNCTION D1MACH ------------------------ -c END - -*DECK XERRWD - SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2) -C***BEGIN PROLOGUE XERRWD -C***SUBSIDIARY -C***PURPOSE Write error message with values. -C***LIBRARY MATHLIB -C***CATEGORY R3C -C***TYPE DOUBLE PRECISION (XERRWV-S, XERRWD-D) -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***DESCRIPTION -C -C Subroutines XERRWD, XSETF, XSETUN, and the function routine IXSAV, -C as given here, constitute a simplified version of the SLATEC error -C handling package. -C -C All arguments are input arguments. -C -C MSG = The message (character array). -C NMES = The length of MSG (number of characters). -C NERR = The error number (not used). -C LEVEL = The error level.. -C 0 or 1 means recoverable (control returns to caller). -C 2 means fatal (run is aborted--see note below). -C NI = Number of integers (0, 1, or 2) to be printed with message. -C I1,I2 = Integers to be printed, depending on NI. -C NR = Number of reals (0, 1, or 2) to be printed with message. -C R1,R2 = Reals to be printed, depending on NR. -C -C Note.. this routine is machine-dependent and specialized for use -C in limited context, in the following ways.. -C 1. The argument MSG is assumed to be of type CHARACTER, and -C the message is printed with a format of (1X,A). -C 2. The message is assumed to take only one line. -C Multi-line messages are generated by repeated calls. -C 3. If LEVEL = 2, control passes to the statement STOP -C to abort the run. This statement may be machine-dependent. -C 4. R1 and R2 are assumed to be in double precision and are printed -C in D21.13 format. -C -C***ROUTINES CALLED IXSAV -C***REVISION HISTORY (YYMMDD) -C 920831 DATE WRITTEN -C 921118 Replaced MFLGSV/LUNSAV by IXSAV. (ACH) -C 930329 Modified prologue to SLATEC format. (FNF) -C 930407 Changed MSG from CHARACTER*1 array to variable. (FNF) -C 930922 Minor cosmetic change. (FNF) -C***END PROLOGUE XERRWD -C -C*Internal Notes: -C -C For a different default logical unit number, IXSAV (or a subsidiary -C routine that it calls) will need to be modified. -C For a different run-abort command, change the statement following -C statement 100 at the end. -C----------------------------------------------------------------------- -C Subroutines called by XERRWD.. None -C Function routine called by XERRWD.. IXSAV -C----------------------------------------------------------------------- -C**End -C -C Declare arguments. -C - DOUBLE PRECISION R1, R2 - INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR - CHARACTER*(*) MSG -C -C Declare local variables. -C - INTEGER LUNIT, IXSAV, MESFLG -C -C Get logical unit number and message print flag. -C -C***FIRST EXECUTABLE STATEMENT XERRWD - LUNIT = IXSAV (1, 0, .FALSE.) - MESFLG = IXSAV (2, 0, .FALSE.) - IF (MESFLG .EQ. 0) GO TO 100 -C -C Write the message. -C - WRITE (LUNIT,10) MSG - 10 FORMAT(1X,A) - IF (NI .EQ. 1) WRITE (LUNIT, 20) I1 - 20 FORMAT(6X,'In above message, I1 =',I10) - IF (NI .EQ. 2) WRITE (LUNIT, 30) I1,I2 - 30 FORMAT(6X,'In above message, I1 =',I10,3X,'I2 =',I10) - IF (NR .EQ. 1) WRITE (LUNIT, 40) R1 - 40 FORMAT(6X,'In above message, R1 =',D21.13) - IF (NR .EQ. 2) WRITE (LUNIT, 50) R1,R2 - 50 FORMAT(6X,'In above, R1 =',D21.13,3X,'R2 =',D21.13) -C -C Abort the run if LEVEL = 2. -C - 100 IF (LEVEL .NE. 2) RETURN - STOP -C----------------------- End of Subroutine XERRWD ---------------------- - END -*DECK XSETF - SUBROUTINE XSETF (MFLAG) -C***BEGIN PROLOGUE XSETF -C***PURPOSE Reset the error print control flag. -C***LIBRARY MATHLIB -C***CATEGORY R3A -C***TYPE ALL (XSETF-A) -C***KEYWORDS ERROR CONTROL -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***DESCRIPTION -C -C XSETF sets the error print control flag to MFLAG: -C MFLAG=1 means print all messages (the default). -C MFLAG=0 means no printing. -C -C***SEE ALSO XERMSG, XERRWD, XERRWV -C***REFERENCES (NONE) -C***ROUTINES CALLED IXSAV -C***REVISION HISTORY (YYMMDD) -C 921118 DATE WRITTEN -C 930329 Added SLATEC format prologue. (FNF) -C 930407 Corrected SEE ALSO section. (FNF) -C 930922 Made user-callable, and other cosmetic changes. (FNF) -C***END PROLOGUE XSETF -C -C Subroutines called by XSETF.. None -C Function routine called by XSETF.. IXSAV -C----------------------------------------------------------------------- -C**End - INTEGER MFLAG, JUNK, IXSAV -C -C***FIRST EXECUTABLE STATEMENT XSETF - IF (MFLAG .EQ. 0 .OR. MFLAG .EQ. 1) JUNK = IXSAV (2,MFLAG,.TRUE.) - RETURN -C----------------------- End of Subroutine XSETF ----------------------- - END -*DECK XSETUN - SUBROUTINE XSETUN (LUN) -C***BEGIN PROLOGUE XSETUN -C***PURPOSE Reset the logical unit number for error messages. -C***LIBRARY MATHLIB -C***CATEGORY R3B -C***TYPE ALL (XSETUN-A) -C***KEYWORDS ERROR CONTROL -C***DESCRIPTION -C -C XSETUN sets the logical unit number for error messages to LUN. -C -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***SEE ALSO XERMSG, XERRWD, XERRWV -C***REFERENCES (NONE) -C***ROUTINES CALLED IXSAV -C***REVISION HISTORY (YYMMDD) -C 921118 DATE WRITTEN -C 930329 Added SLATEC format prologue. (FNF) -C 930407 Corrected SEE ALSO section. (FNF) -C 930922 Made user-callable, and other cosmetic changes. (FNF) -C***END PROLOGUE XSETUN -C -C Subroutines called by XSETUN.. None -C Function routine called by XSETUN.. IXSAV -C----------------------------------------------------------------------- -C**End - INTEGER LUN, JUNK, IXSAV -C -C***FIRST EXECUTABLE STATEMENT XSETUN - IF (LUN .GT. 0) JUNK = IXSAV (1,LUN,.TRUE.) - RETURN -C----------------------- End of Subroutine XSETUN ---------------------- - END -*DECK IXSAV - INTEGER FUNCTION IXSAV (IPAR, IVALUE, ISET) -C***BEGIN PROLOGUE IXSAV -C***SUBSIDIARY -C***PURPOSE Save and recall error message control parameters. -C***LIBRARY MATHLIB -C***CATEGORY R3C -C***TYPE ALL (IXSAV-A) -C***AUTHOR Hindmarsh, Alan C., (LLNL) -C***DESCRIPTION -C -C IXSAV saves and recalls one of two error message parameters: -C LUNIT, the logical unit number to which messages are printed, and -C MESFLG, the message print flag. -C This is a modification of the SLATEC library routine J4SAVE. -C -C Saved local variables.. -C LUNIT = Logical unit number for messages. -C LUNDEF = Default logical unit number, data-loaded to 6 below -C (may be machine-dependent). -C MESFLG = Print control flag.. -C 1 means print all messages (the default). -C 0 means no printing. -C -C On input.. -C IPAR = Parameter indicator (1 for LUNIT, 2 for MESFLG). -C IVALUE = The value to be set for the parameter, if ISET = .TRUE. -C ISET = Logical flag to indicate whether to read or write. -C If ISET = .TRUE., the parameter will be given -C the value IVALUE. If ISET = .FALSE., the parameter -C will be unchanged, and IVALUE is a dummy argument. -C -C On return.. -C IXSAV = The (old) value of the parameter. -C -C***SEE ALSO XERMSG, XERRWD, XERRWV -C***ROUTINES CALLED NONE -C***REVISION HISTORY (YYMMDD) -C 921118 DATE WRITTEN -C 930329 Modified prologue to SLATEC format. (FNF) -C 941025 Minor modification re default unit number. (ACH) -C***END PROLOGUE IXSAV -C -C**End - LOGICAL ISET - INTEGER IPAR, IVALUE -C----------------------------------------------------------------------- - INTEGER LUNIT, LUNDEF, MESFLG -C----------------------------------------------------------------------- -C The following Fortran-77 declaration is to cause the values of the -C listed (local) variables to be saved between calls to this routine. -C----------------------------------------------------------------------- -c SAVE LUNIT, LUNDEF, MESFLG -c dgg mod 2/2007 - lunit = -1 - lundef = 6 - mesflg = 1 -c DATA LUNIT/-1/, LUNDEF/6/, MESFLG/1/ -C -C***FIRST EXECUTABLE STATEMENT IXSAV - IF (IPAR .EQ. 1) THEN - IF (LUNIT .EQ. -1) LUNIT = LUNDEF - IXSAV = LUNIT - IF (ISET) LUNIT = IVALUE - ENDIF -C - IF (IPAR .EQ. 2) THEN - IXSAV = MESFLG - IF (ISET) MESFLG = IVALUE - ENDIF -C - RETURN -C----------------------- End of Function IXSAV ------------------------- - END diff --git a/ext/math/ddaspk.f b/ext/math/ddaspk.f deleted file mode 100644 index d7bd0be2f..000000000 --- a/ext/math/ddaspk.f +++ /dev/null @@ -1,6612 +0,0 @@ - SUBROUTINE DDASPK (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, - * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL) -C -C***BEGIN PROLOGUE DDASPK -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 910624 (Added HMAX test at 525 in main driver.) -C***REVISION DATE 920929 (CJ in RES call, RES counter fix.) -C***REVISION DATE 921215 (Warnings on poor iteration performance) -C***REVISION DATE 921216 (NRMAX as optional input) -C***REVISION DATE 930315 (Name change: DDINI to DDINIT) -C***REVISION DATE 940822 (Replaced initial condition calculation) -C***REVISION DATE 941101 (Added linesearch in I.C. calculations) -C***REVISION DATE 941220 (Misc. corrections throughout) -C***REVISION DATE 950125 (Added DINVWT routine) -C***REVISION DATE 950714 (Misc. corrections throughout) -C***REVISION DATE 950802 (Default NRMAX = 5, based on tests.) -C***REVISION DATE 950808 (Optional error test added.) -C***REVISION DATE 950814 (Added I.C. constraints and INFO(14)) -C***REVISION DATE 950828 (Various minor corrections.) -C***REVISION DATE 951006 (Corrected WT scaling in DFNRMK.) -C***REVISION DATE 951030 (Corrected history update at end of DDASTP.) -C***REVISION DATE 960129 (Corrected RL bug in DLINSD, DLINSK.) -C***REVISION DATE 960301 (Added NONNEG to SAVE statement.) -C***REVISION DATE 000512 (Removed copyright notices.) -C***REVISION DATE 000622 (Corrected LWM value using NCPHI.) -C***REVISION DATE 000628 (Corrected I.C. stopping tests when index = 0.) -C***REVISION DATE 000628 (Fixed alpha test in I.C. calc., Krylov case.) -C***REVISION DATE 000628 (Improved restart in I.C. calc., Krylov case.) -C***REVISION DATE 000628 (Minor corrections throughout.) -C***REVISION DATE 000711 (Fixed Newton convergence test in DNSD, DNSK.) -C***REVISION DATE 000712 (Fixed tests on TN - TOUT below 420 and 440.) -C***CATEGORY NO. I1A2 -C***KEYWORDS DIFFERENTIAL/ALGEBRAIC, BACKWARD DIFFERENTIATION FORMULAS, -C IMPLICIT DIFFERENTIAL SYSTEMS, KRYLOV ITERATION -C***AUTHORS Linda R. Petzold, Peter N. Brown, Alan C. Hindmarsh, and -C Clement W. Ulrich -C Center for Computational Sciences & Engineering, L-316 -C Lawrence Livermore National Laboratory -C P.O. Box 808, -C Livermore, CA 94551 -C***PURPOSE This code solves a system of differential/algebraic -C equations of the form -C G(t,y,y') = 0 , -C using a combination of Backward Differentiation Formula -C (BDF) methods and a choice of two linear system solution -C methods: direct (dense or band) or Krylov (iterative). -C This version is in double precision. -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C *Usage: -C -C IMPLICIT DOUBLE PRECISION(A-H,O-Z) -C INTEGER NEQ, INFO(N), IDID, LRW, LIW, IWORK(LIW), IPAR(*) -C DOUBLE PRECISION T, Y(*), YPRIME(*), TOUT, RTOL(*), ATOL(*), -C RWORK(LRW), RPAR(*) -C EXTERNAL RES, JAC, PSOL -C -C CALL DDASPK (RES, NEQ, T, Y, YPRIME, TOUT, INFO, RTOL, ATOL, -C * IDID, RWORK, LRW, IWORK, LIW, RPAR, IPAR, JAC, PSOL) -C -C Quantities which may be altered by the code are: -C T, Y(*), YPRIME(*), INFO(1), RTOL, ATOL, IDID, RWORK(*), IWORK(*) -C -C -C *Arguments: -C -C RES:EXT This is the name of a subroutine which you -C provide to define the residual function G(t,y,y') -C of the differential/algebraic system. -C -C NEQ:IN This is the number of equations in the system. -C -C T:INOUT This is the current value of the independent -C variable. -C -C Y(*):INOUT This array contains the solution components at T. -C -C YPRIME(*):INOUT This array contains the derivatives of the solution -C components at T. -C -C TOUT:IN This is a point at which a solution is desired. -C -C INFO(N):IN This is an integer array used to communicate details -C of how the solution is to be carried out, such as -C tolerance type, matrix structure, step size and -C order limits, and choice of nonlinear system method. -C N must be at least 20. -C -C RTOL,ATOL:INOUT These quantities represent absolute and relative -C error tolerances (on local error) which you provide -C to indicate how accurately you wish the solution to -C be computed. You may choose them to be both scalars -C or else both arrays of length NEQ. -C -C IDID:OUT This integer scalar is an indicator reporting what -C the code did. You must monitor this variable to -C decide what action to take next. -C -C RWORK:WORK A real work array of length LRW which provides the -C code with needed storage space. -C -C LRW:IN The length of RWORK. -C -C IWORK:WORK An integer work array of length LIW which provides -C the code with needed storage space. -C -C LIW:IN The length of IWORK. -C -C RPAR,IPAR:IN These are real and integer parameter arrays which -C you can use for communication between your calling -C program and the RES, JAC, and PSOL subroutines. -C -C JAC:EXT This is the name of a subroutine which you may -C provide (optionally) for calculating Jacobian -C (partial derivative) data involved in solving linear -C systems within DDASPK. -C -C PSOL:EXT This is the name of a subroutine which you must -C provide for solving linear systems if you selected -C a Krylov method. The purpose of PSOL is to solve -C linear systems involving a left preconditioner P. -C -C *Overview -C -C The DDASPK solver uses the backward differentiation formulas of -C orders one through five to solve a system of the form G(t,y,y') = 0 -C for y = Y and y' = YPRIME. Values for Y and YPRIME at the initial -C time must be given as input. These values should be consistent, -C that is, if T, Y, YPRIME are the given initial values, they should -C satisfy G(T,Y,YPRIME) = 0. However, if consistent values are not -C known, in many cases you can have DDASPK solve for them -- see INFO(11). -C (This and other options are described in more detail below.) -C -C Normally, DDASPK solves the system from T to TOUT. It is easy to -C continue the solution to get results at additional TOUT. This is -C the interval mode of operation. Intermediate results can also be -C obtained easily by specifying INFO(3). -C -C On each step taken by DDASPK, a sequence of nonlinear algebraic -C systems arises. These are solved by one of two types of -C methods: -C * a Newton iteration with a direct method for the linear -C systems involved (INFO(12) = 0), or -C * a Newton iteration with a preconditioned Krylov iterative -C method for the linear systems involved (INFO(12) = 1). -C -C The direct method choices are dense and band matrix solvers, -C with either a user-supplied or an internal difference quotient -C Jacobian matrix, as specified by INFO(5) and INFO(6). -C In the band case, INFO(6) = 1, you must supply half-bandwidths -C in IWORK(1) and IWORK(2). -C -C The Krylov method is the Generalized Minimum Residual (GMRES) -C method, in either complete or incomplete form, and with -C scaling and preconditioning. The method is implemented -C in an algorithm called SPIGMR. Certain options in the Krylov -C method case are specified by INFO(13) and INFO(15). -C -C If the Krylov method is chosen, you may supply a pair of routines, -C JAC and PSOL, to apply preconditioning to the linear system. -C If the system is A*x = b, the matrix is A = dG/dY + CJ*dG/dYPRIME -C (of order NEQ). This system can then be preconditioned in the form -C (P-inverse)*A*x = (P-inverse)*b, with left preconditioner P. -C (DDASPK does not allow right preconditioning.) -C Then the Krylov method is applied to this altered, but equivalent, -C linear system, hopefully with much better performance than without -C preconditioning. (In addition, a diagonal scaling matrix based on -C the tolerances is also introduced into the altered system.) -C -C The JAC routine evaluates any data needed for solving systems -C with coefficient matrix P, and PSOL carries out that solution. -C In any case, in order to improve convergence, you should try to -C make P approximate the matrix A as much as possible, while keeping -C the system P*x = b reasonably easy and inexpensive to solve for x, -C given a vector b. -C -C -C *Description -C -C------INPUT - WHAT TO DO ON THE FIRST CALL TO DDASPK------------------- -C -C -C The first call of the code is defined to be the start of each new -C problem. Read through the descriptions of all the following items, -C provide sufficient storage space for designated arrays, set -C appropriate variables for the initialization of the problem, and -C give information about how you want the problem to be solved. -C -C -C RES -- Provide a subroutine of the form -C -C SUBROUTINE RES (T, Y, YPRIME, CJ, DELTA, IRES, RPAR, IPAR) -C -C to define the system of differential/algebraic -C equations which is to be solved. For the given values -C of T, Y and YPRIME, the subroutine should return -C the residual of the differential/algebraic system -C DELTA = G(T,Y,YPRIME) -C DELTA is a vector of length NEQ which is output from RES. -C -C Subroutine RES must not alter T, Y, YPRIME, or CJ. -C You must declare the name RES in an EXTERNAL -C statement in your program that calls DDASPK. -C You must dimension Y, YPRIME, and DELTA in RES. -C -C The input argument CJ can be ignored, or used to rescale -C constraint equations in the system (see Ref. 2, p. 145). -C Note: In this respect, DDASPK is not downward-compatible -C with DDASSL, which does not have the RES argument CJ. -C -C IRES is an integer flag which is always equal to zero -C on input. Subroutine RES should alter IRES only if it -C encounters an illegal value of Y or a stop condition. -C Set IRES = -1 if an input value is illegal, and DDASPK -C will try to solve the problem without getting IRES = -1. -C If IRES = -2, DDASPK will return control to the calling -C program with IDID = -11. -C -C RPAR and IPAR are real and integer parameter arrays which -C you can use for communication between your calling program -C and subroutine RES. They are not altered by DDASPK. If you -C do not need RPAR or IPAR, ignore these parameters by treat- -C ing them as dummy arguments. If you do choose to use them, -C dimension them in your calling program and in RES as arrays -C of appropriate length. -C -C NEQ -- Set it to the number of equations in the system (NEQ .GE. 1). -C -C T -- Set it to the initial point of the integration. (T must be -C a variable.) -C -C Y(*) -- Set this array to the initial values of the NEQ solution -C components at the initial point. You must dimension Y of -C length at least NEQ in your calling program. -C -C YPRIME(*) -- Set this array to the initial values of the NEQ first -C derivatives of the solution components at the initial -C point. You must dimension YPRIME at least NEQ in your -C calling program. -C -C TOUT - Set it to the first point at which a solution is desired. -C You cannot take TOUT = T. Integration either forward in T -C (TOUT .GT. T) or backward in T (TOUT .LT. T) is permitted. -C -C The code advances the solution from T to TOUT using step -C sizes which are automatically selected so as to achieve the -C desired accuracy. If you wish, the code will return with the -C solution and its derivative at intermediate steps (the -C intermediate-output mode) so that you can monitor them, -C but you still must provide TOUT in accord with the basic -C aim of the code. -C -C The first step taken by the code is a critical one because -C it must reflect how fast the solution changes near the -C initial point. The code automatically selects an initial -C step size which is practically always suitable for the -C problem. By using the fact that the code will not step past -C TOUT in the first step, you could, if necessary, restrict the -C length of the initial step. -C -C For some problems it may not be permissible to integrate -C past a point TSTOP, because a discontinuity occurs there -C or the solution or its derivative is not defined beyond -C TSTOP. When you have declared a TSTOP point (see INFO(4) -C and RWORK(1)), you have told the code not to integrate past -C TSTOP. In this case any tout beyond TSTOP is invalid input. -C -C INFO(*) - Use the INFO array to give the code more details about -C how you want your problem solved. This array should be -C dimensioned of length 20, though DDASPK uses only the -C first 15 entries. You must respond to all of the following -C items, which are arranged as questions. The simplest use -C of DDASPK corresponds to setting all entries of INFO to 0. -C -C INFO(1) - This parameter enables the code to initialize itself. -C You must set it to indicate the start of every new -C problem. -C -C **** Is this the first call for this problem ... -C yes - set INFO(1) = 0 -C no - not applicable here. -C See below for continuation calls. **** -C -C INFO(2) - How much accuracy you want of your solution -C is specified by the error tolerances RTOL and ATOL. -C The simplest use is to take them both to be scalars. -C To obtain more flexibility, they can both be arrays. -C The code must be told your choice. -C -C **** Are both error tolerances RTOL, ATOL scalars ... -C yes - set INFO(2) = 0 -C and input scalars for both RTOL and ATOL -C no - set INFO(2) = 1 -C and input arrays for both RTOL and ATOL **** -C -C INFO(3) - The code integrates from T in the direction of TOUT -C by steps. If you wish, it will return the computed -C solution and derivative at the next intermediate step -C (the intermediate-output mode) or TOUT, whichever comes -C first. This is a good way to proceed if you want to -C see the behavior of the solution. If you must have -C solutions at a great many specific TOUT points, this -C code will compute them efficiently. -C -C **** Do you want the solution only at -C TOUT (and not at the next intermediate step) ... -C yes - set INFO(3) = 0 -C no - set INFO(3) = 1 **** -C -C INFO(4) - To handle solutions at a great many specific -C values TOUT efficiently, this code may integrate past -C TOUT and interpolate to obtain the result at TOUT. -C Sometimes it is not possible to integrate beyond some -C point TSTOP because the equation changes there or it is -C not defined past TSTOP. Then you must tell the code -C this stop condition. -C -C **** Can the integration be carried out without any -C restrictions on the independent variable T ... -C yes - set INFO(4) = 0 -C no - set INFO(4) = 1 -C and define the stopping point TSTOP by -C setting RWORK(1) = TSTOP **** -C -C INFO(5) - used only when INFO(12) = 0 (direct methods). -C To solve differential/algebraic systems you may wish -C to use a matrix of partial derivatives of the -C system of differential equations. If you do not -C provide a subroutine to evaluate it analytically (see -C description of the item JAC in the call list), it will -C be approximated by numerical differencing in this code. -C Although it is less trouble for you to have the code -C compute partial derivatives by numerical differencing, -C the solution will be more reliable if you provide the -C derivatives via JAC. Usually numerical differencing is -C more costly than evaluating derivatives in JAC, but -C sometimes it is not - this depends on your problem. -C -C **** Do you want the code to evaluate the partial deriv- -C atives automatically by numerical differences ... -C yes - set INFO(5) = 0 -C no - set INFO(5) = 1 -C and provide subroutine JAC for evaluating the -C matrix of partial derivatives **** -C -C INFO(6) - used only when INFO(12) = 0 (direct methods). -C DDASPK will perform much better if the matrix of -C partial derivatives, dG/dY + CJ*dG/dYPRIME (here CJ is -C a scalar determined by DDASPK), is banded and the code -C is told this. In this case, the storage needed will be -C greatly reduced, numerical differencing will be performed -C much cheaper, and a number of important algorithms will -C execute much faster. The differential equation is said -C to have half-bandwidths ML (lower) and MU (upper) if -C equation i involves only unknowns Y(j) with -C i-ML .le. j .le. i+MU . -C For all i=1,2,...,NEQ. Thus, ML and MU are the widths -C of the lower and upper parts of the band, respectively, -C with the main diagonal being excluded. If you do not -C indicate that the equation has a banded matrix of partial -C derivatives the code works with a full matrix of NEQ**2 -C elements (stored in the conventional way). Computations -C with banded matrices cost less time and storage than with -C full matrices if 2*ML+MU .lt. NEQ. If you tell the -C code that the matrix of partial derivatives has a banded -C structure and you want to provide subroutine JAC to -C compute the partial derivatives, then you must be careful -C to store the elements of the matrix in the special form -C indicated in the description of JAC. -C -C **** Do you want to solve the problem using a full (dense) -C matrix (and not a special banded structure) ... -C yes - set INFO(6) = 0 -C no - set INFO(6) = 1 -C and provide the lower (ML) and upper (MU) -C bandwidths by setting -C IWORK(1)=ML -C IWORK(2)=MU **** -C -C INFO(7) - You can specify a maximum (absolute value of) -C stepsize, so that the code will avoid passing over very -C large regions. -C -C **** Do you want the code to decide on its own the maximum -C stepsize ... -C yes - set INFO(7) = 0 -C no - set INFO(7) = 1 -C and define HMAX by setting -C RWORK(2) = HMAX **** -C -C INFO(8) - Differential/algebraic problems may occasionally -C suffer from severe scaling difficulties on the first -C step. If you know a great deal about the scaling of -C your problem, you can help to alleviate this problem -C by specifying an initial stepsize H0. -C -C **** Do you want the code to define its own initial -C stepsize ... -C yes - set INFO(8) = 0 -C no - set INFO(8) = 1 -C and define H0 by setting -C RWORK(3) = H0 **** -C -C INFO(9) - If storage is a severe problem, you can save some -C storage by restricting the maximum method order MAXORD. -C The default value is 5. For each order decrease below 5, -C the code requires NEQ fewer locations, but it is likely -C to be slower. In any case, you must have -C 1 .le. MAXORD .le. 5. -C **** Do you want the maximum order to default to 5 ... -C yes - set INFO(9) = 0 -C no - set INFO(9) = 1 -C and define MAXORD by setting -C IWORK(3) = MAXORD **** -C -C INFO(10) - If you know that certain components of the -C solutions to your equations are always nonnegative -C (or nonpositive), it may help to set this -C parameter. There are three options that are -C available: -C 1. To have constraint checking only in the initial -C condition calculation. -C 2. To enforce nonnegativity in Y during the integration. -C 3. To enforce both options 1 and 2. -C -C When selecting option 2 or 3, it is probably best to try the -C code without using this option first, and only use -C this option if that does not work very well. -C -C **** Do you want the code to solve the problem without -C invoking any special inequality constraints ... -C yes - set INFO(10) = 0 -C no - set INFO(10) = 1 to have option 1 enforced -C no - set INFO(10) = 2 to have option 2 enforced -C no - set INFO(10) = 3 to have option 3 enforced **** -C -C If you have specified INFO(10) = 1 or 3, then you -C will also need to identify how each component of Y -C in the initial condition calculation is constrained. -C You must set: -C IWORK(40+I) = +1 if Y(I) must be .GE. 0, -C IWORK(40+I) = +2 if Y(I) must be .GT. 0, -C IWORK(40+I) = -1 if Y(I) must be .LE. 0, while -C IWORK(40+I) = -2 if Y(I) must be .LT. 0, while -C IWORK(40+I) = 0 if Y(I) is not constrained. -C -C INFO(11) - DDASPK normally requires the initial T, Y, and -C YPRIME to be consistent. That is, you must have -C G(T,Y,YPRIME) = 0 at the initial T. If you do not know -C the initial conditions precisely, in some cases -C DDASPK may be able to compute it. -C -C Denoting the differential variables in Y by Y_d -C and the algebraic variables by Y_a, DDASPK can solve -C one of two initialization problems: -C 1. Given Y_d, calculate Y_a and Y'_d, or -C 2. Given Y', calculate Y. -C In either case, initial values for the given -C components are input, and initial guesses for -C the unknown components must also be provided as input. -C -C **** Are the initial T, Y, YPRIME consistent ... -C -C yes - set INFO(11) = 0 -C no - set INFO(11) = 1 to calculate option 1 above, -C or set INFO(11) = 2 to calculate option 2 **** -C -C If you have specified INFO(11) = 1, then you -C will also need to identify which are the -C differential and which are the algebraic -C components (algebraic components are components -C whose derivatives do not appear explicitly -C in the function G(T,Y,YPRIME)). You must set: -C IWORK(LID+I) = +1 if Y(I) is a differential variable -C IWORK(LID+I) = -1 if Y(I) is an algebraic variable, -C where LID = 40 if INFO(10) = 0 or 2 and LID = 40+NEQ -C if INFO(10) = 1 or 3. -C -C INFO(12) - Except for the addition of the RES argument CJ, -C DDASPK by default is downward-compatible with DDASSL, -C which uses only direct (dense or band) methods to solve -C the linear systems involved. You must set INFO(12) to -C indicate whether you want the direct methods or the -C Krylov iterative method. -C **** Do you want DDASPK to use standard direct methods -C (dense or band) or the Krylov (iterative) method ... -C direct methods - set INFO(12) = 0. -C Krylov method - set INFO(12) = 1, -C and check the settings of INFO(13) and INFO(15). -C -C INFO(13) - used when INFO(12) = 1 (Krylov methods). -C DDASPK uses scalars MAXL, KMP, NRMAX, and EPLI for the -C iterative solution of linear systems. INFO(13) allows -C you to override the default values of these parameters. -C These parameters and their defaults are as follows: -C MAXL = maximum number of iterations in the SPIGMR -C algorithm (MAXL .le. NEQ). The default is -C MAXL = MIN(5,NEQ). -C KMP = number of vectors on which orthogonalization is -C done in the SPIGMR algorithm. The default is -C KMP = MAXL, which corresponds to complete GMRES -C iteration, as opposed to the incomplete form. -C NRMAX = maximum number of restarts of the SPIGMR -C algorithm per nonlinear iteration. The default is -C NRMAX = 5. -C EPLI = convergence test constant in SPIGMR algorithm. -C The default is EPLI = 0.05. -C Note that the length of RWORK depends on both MAXL -C and KMP. See the definition of LRW below. -C **** Are MAXL, KMP, and EPLI to be given their -C default values ... -C yes - set INFO(13) = 0 -C no - set INFO(13) = 1, -C and set all of the following: -C IWORK(24) = MAXL (1 .le. MAXL .le. NEQ) -C IWORK(25) = KMP (1 .le. KMP .le. MAXL) -C IWORK(26) = NRMAX (NRMAX .ge. 0) -C RWORK(10) = EPLI (0 .lt. EPLI .lt. 1.0) **** -C -C INFO(14) - used with INFO(11) > 0 (initial condition -C calculation is requested). In this case, you may -C request control to be returned to the calling program -C immediately after the initial condition calculation, -C before proceeding to the integration of the system -C (e.g. to examine the computed Y and YPRIME). -C If this is done, and if the initialization succeeded -C (IDID = 4), you should reset INFO(11) to 0 for the -C next call, to prevent the solver from repeating the -C initialization (and to avoid an infinite loop). -C **** Do you want to proceed to the integration after -C the initial condition calculation is done ... -C yes - set INFO(14) = 0 -C no - set INFO(14) = 1 **** -C -C INFO(15) - used when INFO(12) = 1 (Krylov methods). -C When using preconditioning in the Krylov method, -C you must supply a subroutine, PSOL, which solves the -C associated linear systems using P. -C The usage of DDASPK is simpler if PSOL can carry out -C the solution without any prior calculation of data. -C However, if some partial derivative data is to be -C calculated in advance and used repeatedly in PSOL, -C then you must supply a JAC routine to do this, -C and set INFO(15) to indicate that JAC is to be called -C for this purpose. For example, P might be an -C approximation to a part of the matrix A which can be -C calculated and LU-factored for repeated solutions of -C the preconditioner system. The arrays WP and IWP -C (described under JAC and PSOL) can be used to -C communicate data between JAC and PSOL. -C **** Does PSOL operate with no prior preparation ... -C yes - set INFO(15) = 0 (no JAC routine) -C no - set INFO(15) = 1 -C and supply a JAC routine to evaluate and -C preprocess any required Jacobian data. **** -C -C INFO(16) - option to exclude algebraic variables from -C the error test. -C **** Do you wish to control errors locally on -C all the variables... -C yes - set INFO(16) = 0 -C no - set INFO(16) = 1 -C If you have specified INFO(16) = 1, then you -C will also need to identify which are the -C differential and which are the algebraic -C components (algebraic components are components -C whose derivatives do not appear explicitly -C in the function G(T,Y,YPRIME)). You must set: -C IWORK(LID+I) = +1 if Y(I) is a differential -C variable, and -C IWORK(LID+I) = -1 if Y(I) is an algebraic -C variable, -C where LID = 40 if INFO(10) = 0 or 2 and -C LID = 40 + NEQ if INFO(10) = 1 or 3. -C -C INFO(17) - used when INFO(11) > 0 (DDASPK is to do an -C initial condition calculation). -C DDASPK uses several heuristic control quantities in the -C initial condition calculation. They have default values, -C but can also be set by the user using INFO(17). -C These parameters and their defaults are as follows: -C MXNIT = maximum number of Newton iterations -C per Jacobian or preconditioner evaluation. -C The default is: -C MXNIT = 5 in the direct case (INFO(12) = 0), and -C MXNIT = 15 in the Krylov case (INFO(12) = 1). -C MXNJ = maximum number of Jacobian or preconditioner -C evaluations. The default is: -C MXNJ = 6 in the direct case (INFO(12) = 0), and -C MXNJ = 2 in the Krylov case (INFO(12) = 1). -C MXNH = maximum number of values of the artificial -C stepsize parameter H to be tried if INFO(11) = 1. -C The default is MXNH = 5. -C NOTE: the maximum number of Newton iterations -C allowed in all is MXNIT*MXNJ*MXNH if INFO(11) = 1, -C and MXNIT*MXNJ if INFO(11) = 2. -C LSOFF = flag to turn off the linesearch algorithm -C (LSOFF = 0 means linesearch is on, LSOFF = 1 means -C it is turned off). The default is LSOFF = 0. -C STPTOL = minimum scaled step in linesearch algorithm. -C The default is STPTOL = (unit roundoff)**(2/3). -C EPINIT = swing factor in the Newton iteration convergence -C test. The test is applied to the residual vector, -C premultiplied by the approximate Jacobian (in the -C direct case) or the preconditioner (in the Krylov -C case). For convergence, the weighted RMS norm of -C this vector (scaled by the error weights) must be -C less than EPINIT*EPCON, where EPCON = .33 is the -C analogous test constant used in the time steps. -C The default is EPINIT = .01. -C **** Are the initial condition heuristic controls to be -C given their default values... -C yes - set INFO(17) = 0 -C no - set INFO(17) = 1, -C and set all of the following: -C IWORK(32) = MXNIT (.GT. 0) -C IWORK(33) = MXNJ (.GT. 0) -C IWORK(34) = MXNH (.GT. 0) -C IWORK(35) = LSOFF ( = 0 or 1) -C RWORK(14) = STPTOL (.GT. 0.0) -C RWORK(15) = EPINIT (.GT. 0.0) **** -C -C INFO(18) - option to get extra printing in initial condition -C calculation. -C **** Do you wish to have extra printing... -C no - set INFO(18) = 0 -C yes - set INFO(18) = 1 for minimal printing, or -C set INFO(18) = 2 for full printing. -C If you have specified INFO(18) .ge. 1, data -C will be printed with the error handler routines. -C To print to a non-default unit number L, include -C the line CALL XSETUN(L) in your program. **** -C -C RTOL, ATOL -- You must assign relative (RTOL) and absolute (ATOL) -C error tolerances to tell the code how accurately you -C want the solution to be computed. They must be defined -C as variables because the code may change them. -C you have two choices -- -C Both RTOL and ATOL are scalars (INFO(2) = 0), or -C both RTOL and ATOL are vectors (INFO(2) = 1). -C In either case all components must be non-negative. -C -C The tolerances are used by the code in a local error -C test at each step which requires roughly that -C abs(local error in Y(i)) .le. EWT(i) , -C where EWT(i) = RTOL*abs(Y(i)) + ATOL is an error weight -C quantity, for each vector component. -C (More specifically, a root-mean-square norm is used to -C measure the size of vectors, and the error test uses the -C magnitude of the solution at the beginning of the step.) -C -C The true (global) error is the difference between the -C true solution of the initial value problem and the -C computed approximation. Practically all present day -C codes, including this one, control the local error at -C each step and do not even attempt to control the global -C error directly. -C -C Usually, but not always, the true accuracy of -C the computed Y is comparable to the error tolerances. -C This code will usually, but not always, deliver a more -C accurate solution if you reduce the tolerances and -C integrate again. By comparing two such solutions you -C can get a fairly reliable idea of the true error in the -C solution at the larger tolerances. -C -C Setting ATOL = 0. results in a pure relative error test -C on that component. Setting RTOL = 0. results in a pure -C absolute error test on that component. A mixed test -C with non-zero RTOL and ATOL corresponds roughly to a -C relative error test when the solution component is -C much bigger than ATOL and to an absolute error test -C when the solution component is smaller than the -C threshold ATOL. -C -C The code will not attempt to compute a solution at an -C accuracy unreasonable for the machine being used. It -C will advise you if you ask for too much accuracy and -C inform you as to the maximum accuracy it believes -C possible. -C -C RWORK(*) -- a real work array, which should be dimensioned in your -C calling program with a length equal to the value of -C LRW (or greater). -C -C LRW -- Set it to the declared length of the RWORK array. The -C minimum length depends on the options you have selected, -C given by a base value plus additional storage as described -C below. -C -C If INFO(12) = 0 (standard direct method), the base value is -C base = 50 + max(MAXORD+4,7)*NEQ. -C The default value is MAXORD = 5 (see INFO(9)). With the -C default MAXORD, base = 50 + 9*NEQ. -C Additional storage must be added to the base value for -C any or all of the following options: -C if INFO(6) = 0 (dense matrix), add NEQ**2 -C if INFO(6) = 1 (banded matrix), then -C if INFO(5) = 0, add (2*ML+MU+1)*NEQ + 2*(NEQ/(ML+MU+1)+1), -C if INFO(5) = 1, add (2*ML+MU+1)*NEQ, -C if INFO(16) = 1, add NEQ. -C -C If INFO(12) = 1 (Krylov method), the base value is -C base = 50 + (MAXORD+5)*NEQ + (MAXL+3+MIN0(1,MAXL-KMP))*NEQ + -C + (MAXL+3)*MAXL + 1 + LENWP. -C See PSOL for description of LENWP. The default values are: -C MAXORD = 5 (see INFO(9)), MAXL = min(5,NEQ) and KMP = MAXL -C (see INFO(13)). -C With the default values for MAXORD, MAXL and KMP, -C base = 91 + 18*NEQ + LENWP. -C Additional storage must be added to the base value for -C any or all of the following options: -C if INFO(16) = 1, add NEQ. -C -C -C IWORK(*) -- an integer work array, which should be dimensioned in -C your calling program with a length equal to the value -C of LIW (or greater). -C -C LIW -- Set it to the declared length of the IWORK array. The -C minimum length depends on the options you have selected, -C given by a base value plus additional storage as described -C below. -C -C If INFO(12) = 0 (standard direct method), the base value is -C base = 40 + NEQ. -C IF INFO(10) = 1 or 3, add NEQ to the base value. -C If INFO(11) = 1 or INFO(16) =1, add NEQ to the base value. -C -C If INFO(12) = 1 (Krylov method), the base value is -C base = 40 + LENIWP. -C See PSOL for description of LENIWP. -C IF INFO(10) = 1 or 3, add NEQ to the base value. -C If INFO(11) = 1 or INFO(16) = 1, add NEQ to the base value. -C -C -C RPAR, IPAR -- These are arrays of double precision and integer type, -C respectively, which are available for you to use -C for communication between your program that calls -C DDASPK and the RES subroutine (and the JAC and PSOL -C subroutines). They are not altered by DDASPK. -C If you do not need RPAR or IPAR, ignore these -C parameters by treating them as dummy arguments. -C If you do choose to use them, dimension them in -C your calling program and in RES (and in JAC and PSOL) -C as arrays of appropriate length. -C -C JAC -- This is the name of a routine that you may supply -C (optionally) that relates to the Jacobian matrix of the -C nonlinear system that the code must solve at each T step. -C The role of JAC (and its call sequence) depends on whether -C a direct (INFO(12) = 0) or Krylov (INFO(12) = 1) method -C is selected. -C -C **** INFO(12) = 0 (direct methods): -C If you are letting the code generate partial derivatives -C numerically (INFO(5) = 0), then JAC can be absent -C (or perhaps a dummy routine to satisfy the loader). -C Otherwise you must supply a JAC routine to compute -C the matrix A = dG/dY + CJ*dG/dYPRIME. It must have -C the form -C -C SUBROUTINE JAC (T, Y, YPRIME, PD, CJ, RPAR, IPAR) -C -C The JAC routine must dimension Y, YPRIME, and PD (and RPAR -C and IPAR if used). CJ is a scalar which is input to JAC. -C For the given values of T, Y, and YPRIME, the JAC routine -C must evaluate the nonzero elements of the matrix A, and -C store these values in the array PD. The elements of PD are -C set to zero before each call to JAC, so that only nonzero -C elements need to be defined. -C The way you store the elements into the PD array depends -C on the structure of the matrix indicated by INFO(6). -C *** INFO(6) = 0 (full or dense matrix) *** -C Give PD a first dimension of NEQ. When you evaluate the -C nonzero partial derivatives of equation i (i.e. of G(i)) -C with respect to component j (of Y and YPRIME), you must -C store the element in PD according to -C PD(i,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). -C *** INFO(6) = 1 (banded matrix with half-bandwidths ML, MU -C as described under INFO(6)) *** -C Give PD a first dimension of 2*ML+MU+1. When you -C evaluate the nonzero partial derivatives of equation i -C (i.e. of G(i)) with respect to component j (of Y and -C YPRIME), you must store the element in PD according to -C IROW = i - j + ML + MU + 1 -C PD(IROW,j) = dG(i)/dY(j) + CJ*dG(i)/dYPRIME(j). -C -C **** INFO(12) = 1 (Krylov method): -C If you are not calculating Jacobian data in advance for use -C in PSOL (INFO(15) = 0), JAC can be absent (or perhaps a -C dummy routine to satisfy the loader). Otherwise, you may -C supply a JAC routine to compute and preprocess any parts of -C of the Jacobian matrix A = dG/dY + CJ*dG/dYPRIME that are -C involved in the preconditioner matrix P. -C It is to have the form -C -C SUBROUTINE JAC (RES, IRES, NEQ, T, Y, YPRIME, REWT, SAVR, -C WK, H, CJ, WP, IWP, IER, RPAR, IPAR) -C -C The JAC routine must dimension Y, YPRIME, REWT, SAVR, WK, -C and (if used) WP, IWP, RPAR, and IPAR. -C The Y, YPRIME, and SAVR arrays contain the current values -C of Y, YPRIME, and the residual G, respectively. -C The array WK is work space of length NEQ. -C H is the step size. CJ is a scalar, input to JAC, that is -C normally proportional to 1/H. REWT is an array of -C reciprocal error weights, 1/EWT(i), where EWT(i) is -C RTOL*abs(Y(i)) + ATOL (unless you supplied routine DDAWTS -C instead), for use in JAC if needed. For example, if JAC -C computes difference quotient approximations to partial -C derivatives, the REWT array may be useful in setting the -C increments used. The JAC routine should do any -C factorization operations called for, in preparation for -C solving linear systems in PSOL. The matrix P should -C be an approximation to the Jacobian, -C A = dG/dY + CJ*dG/dYPRIME. -C -C WP and IWP are real and integer work arrays which you may -C use for communication between your JAC routine and your -C PSOL routine. These may be used to store elements of the -C preconditioner P, or related matrix data (such as factored -C forms). They are not altered by DDASPK. -C If you do not need WP or IWP, ignore these parameters by -C treating them as dummy arguments. If you do use them, -C dimension them appropriately in your JAC and PSOL routines. -C See the PSOL description for instructions on setting -C the lengths of WP and IWP. -C -C On return, JAC should set the error flag IER as follows.. -C IER = 0 if JAC was successful, -C IER .ne. 0 if JAC was unsuccessful (e.g. if Y or YPRIME -C was illegal, or a singular matrix is found). -C (If IER .ne. 0, a smaller stepsize will be tried.) -C IER = 0 on entry to JAC, so need be reset only on a failure. -C If RES is used within JAC, then a nonzero value of IRES will -C override any nonzero value of IER (see the RES description). -C -C Regardless of the method type, subroutine JAC must not -C alter T, Y(*), YPRIME(*), H, CJ, or REWT(*). -C You must declare the name JAC in an EXTERNAL statement in -C your program that calls DDASPK. -C -C PSOL -- This is the name of a routine you must supply if you have -C selected a Krylov method (INFO(12) = 1) with preconditioning. -C In the direct case (INFO(12) = 0), PSOL can be absent -C (a dummy routine may have to be supplied to satisfy the -C loader). Otherwise, you must provide a PSOL routine to -C solve linear systems arising from preconditioning. -C When supplied with INFO(12) = 1, the PSOL routine is to -C have the form -C -C SUBROUTINE PSOL (NEQ, T, Y, YPRIME, SAVR, WK, CJ, WGHT, -C WP, IWP, B, EPLIN, IER, RPAR, IPAR) -C -C The PSOL routine must solve linear systems of the form -C P*x = b where P is the left preconditioner matrix. -C -C The right-hand side vector b is in the B array on input, and -C PSOL must return the solution vector x in B. -C The Y, YPRIME, and SAVR arrays contain the current values -C of Y, YPRIME, and the residual G, respectively. -C -C Work space required by JAC and/or PSOL, and space for data to -C be communicated from JAC to PSOL is made available in the form -C of arrays WP and IWP, which are parts of the RWORK and IWORK -C arrays, respectively. The lengths of these real and integer -C work spaces WP and IWP must be supplied in LENWP and LENIWP, -C respectively, as follows.. -C IWORK(27) = LENWP = length of real work space WP -C IWORK(28) = LENIWP = length of integer work space IWP. -C -C WK is a work array of length NEQ for use by PSOL. -C CJ is a scalar, input to PSOL, that is normally proportional -C to 1/H (H = stepsize). If the old value of CJ -C (at the time of the last JAC call) is needed, it must have -C been saved by JAC in WP. -C -C WGHT is an array of weights, to be used if PSOL uses an -C iterative method and performs a convergence test. (In terms -C of the argument REWT to JAC, WGHT is REWT/sqrt(NEQ).) -C If PSOL uses an iterative method, it should use EPLIN -C (a heuristic parameter) as the bound on the weighted norm of -C the residual for the computed solution. Specifically, the -C residual vector R should satisfy -C SQRT (SUM ( (R(i)*WGHT(i))**2 ) ) .le. EPLIN -C -C PSOL must not alter NEQ, T, Y, YPRIME, SAVR, CJ, WGHT, EPLIN. -C -C On return, PSOL should set the error flag IER as follows.. -C IER = 0 if PSOL was successful, -C IER .lt. 0 if an unrecoverable error occurred, meaning -C control will be passed to the calling routine, -C IER .gt. 0 if a recoverable error occurred, meaning that -C the step will be retried with the same step size -C but with a call to JAC to update necessary data, -C unless the Jacobian data is current, in which case -C the step will be retried with a smaller step size. -C IER = 0 on entry to PSOL so need be reset only on a failure. -C -C You must declare the name PSOL in an EXTERNAL statement in -C your program that calls DDASPK. -C -C -C OPTIONALLY REPLACEABLE SUBROUTINE: -C -C DDASPK uses a weighted root-mean-square norm to measure the -C size of various error vectors. The weights used in this norm -C are set in the following subroutine: -C -C SUBROUTINE DDAWTS (NEQ, IWT, RTOL, ATOL, Y, EWT, RPAR, IPAR) -C DIMENSION RTOL(*), ATOL(*), Y(*), EWT(*), RPAR(*), IPAR(*) -C -C A DDAWTS routine has been included with DDASPK which sets the -C weights according to -C EWT(I) = RTOL*ABS(Y(I)) + ATOL -C in the case of scalar tolerances (IWT = 0) or -C EWT(I) = RTOL(I)*ABS(Y(I)) + ATOL(I) -C in the case of array tolerances (IWT = 1). (IWT is INFO(2).) -C In some special cases, it may be appropriate for you to define -C your own error weights by writing a subroutine DDAWTS to be -C called instead of the version supplied. However, this should -C be attempted only after careful thought and consideration. -C If you supply this routine, you may use the tolerances and Y -C as appropriate, but do not overwrite these variables. You -C may also use RPAR and IPAR to communicate data as appropriate. -C ***Note: Aside from the values of the weights, the choice of -C norm used in DDASPK (weighted root-mean-square) is not subject -C to replacement by the user. In this respect, DDASPK is not -C downward-compatible with the original DDASSL solver (in which -C the norm routine was optionally user-replaceable). -C -C -C------OUTPUT - AFTER ANY RETURN FROM DDASPK---------------------------- -C -C The principal aim of the code is to return a computed solution at -C T = TOUT, although it is also possible to obtain intermediate -C results along the way. To find out whether the code achieved its -C goal or if the integration process was interrupted before the task -C was completed, you must check the IDID parameter. -C -C -C T -- The output value of T is the point to which the solution -C was successfully advanced. -C -C Y(*) -- contains the computed solution approximation at T. -C -C YPRIME(*) -- contains the computed derivative approximation at T. -C -C IDID -- reports what the code did, described as follows: -C -C *** TASK COMPLETED *** -C Reported by positive values of IDID -C -C IDID = 1 -- a step was successfully taken in the -C intermediate-output mode. The code has not -C yet reached TOUT. -C -C IDID = 2 -- the integration to TSTOP was successfully -C completed (T = TSTOP) by stepping exactly to TSTOP. -C -C IDID = 3 -- the integration to TOUT was successfully -C completed (T = TOUT) by stepping past TOUT. -C Y(*) and YPRIME(*) are obtained by interpolation. -C -C IDID = 4 -- the initial condition calculation, with -C INFO(11) > 0, was successful, and INFO(14) = 1. -C No integration steps were taken, and the solution -C is not considered to have been started. -C -C *** TASK INTERRUPTED *** -C Reported by negative values of IDID -C -C IDID = -1 -- a large amount of work has been expended -C (about 500 steps). -C -C IDID = -2 -- the error tolerances are too stringent. -C -C IDID = -3 -- the local error test cannot be satisfied -C because you specified a zero component in ATOL -C and the corresponding computed solution component -C is zero. Thus, a pure relative error test is -C impossible for this component. -C -C IDID = -5 -- there were repeated failures in the evaluation -C or processing of the preconditioner (in JAC). -C -C IDID = -6 -- DDASPK had repeated error test failures on the -C last attempted step. -C -C IDID = -7 -- the nonlinear system solver in the time integration -C could not converge. -C -C IDID = -8 -- the matrix of partial derivatives appears -C to be singular (direct method). -C -C IDID = -9 -- the nonlinear system solver in the time integration -C failed to achieve convergence, and there were repeated -C error test failures in this step. -C -C IDID =-10 -- the nonlinear system solver in the time integration -C failed to achieve convergence because IRES was equal -C to -1. -C -C IDID =-11 -- IRES = -2 was encountered and control is -C being returned to the calling program. -C -C IDID =-12 -- DDASPK failed to compute the initial Y, YPRIME. -C -C IDID =-13 -- unrecoverable error encountered inside user's -C PSOL routine, and control is being returned to -C the calling program. -C -C IDID =-14 -- the Krylov linear system solver could not -C achieve convergence. -C -C IDID =-15,..,-32 -- Not applicable for this code. -C -C *** TASK TERMINATED *** -C reported by the value of IDID=-33 -C -C IDID = -33 -- the code has encountered trouble from which -C it cannot recover. A message is printed -C explaining the trouble and control is returned -C to the calling program. For example, this occurs -C when invalid input is detected. -C -C RTOL, ATOL -- these quantities remain unchanged except when -C IDID = -2. In this case, the error tolerances have been -C increased by the code to values which are estimated to -C be appropriate for continuing the integration. However, -C the reported solution at T was obtained using the input -C values of RTOL and ATOL. -C -C RWORK, IWORK -- contain information which is usually of no interest -C to the user but necessary for subsequent calls. -C However, you may be interested in the performance data -C listed below. These quantities are accessed in RWORK -C and IWORK but have internal mnemonic names, as follows.. -C -C RWORK(3)--contains H, the step size h to be attempted -C on the next step. -C -C RWORK(4)--contains TN, the current value of the -C independent variable, i.e. the farthest point -C integration has reached. This will differ -C from T if interpolation has been performed -C (IDID = 3). -C -C RWORK(7)--contains HOLD, the stepsize used on the last -C successful step. If INFO(11) = INFO(14) = 1, -C this contains the value of H used in the -C initial condition calculation. -C -C IWORK(7)--contains K, the order of the method to be -C attempted on the next step. -C -C IWORK(8)--contains KOLD, the order of the method used -C on the last step. -C -C IWORK(11)--contains NST, the number of steps (in T) -C taken so far. -C -C IWORK(12)--contains NRE, the number of calls to RES -C so far. -C -C IWORK(13)--contains NJE, the number of calls to JAC so -C far (Jacobian or preconditioner evaluations). -C -C IWORK(14)--contains NETF, the total number of error test -C failures so far. -C -C IWORK(15)--contains NCFN, the total number of nonlinear -C convergence failures so far (includes counts -C of singular iteration matrix or singular -C preconditioners). -C -C IWORK(16)--contains NCFL, the number of convergence -C failures of the linear iteration so far. -C -C IWORK(17)--contains LENIW, the length of IWORK actually -C required. This is defined on normal returns -C and on an illegal input return for -C insufficient storage. -C -C IWORK(18)--contains LENRW, the length of RWORK actually -C required. This is defined on normal returns -C and on an illegal input return for -C insufficient storage. -C -C IWORK(19)--contains NNI, the total number of nonlinear -C iterations so far (each of which calls a -C linear solver). -C -C IWORK(20)--contains NLI, the total number of linear -C (Krylov) iterations so far. -C -C IWORK(21)--contains NPS, the number of PSOL calls so -C far, for preconditioning solve operations or -C for solutions with the user-supplied method. -C -C Note: The various counters in IWORK do not include -C counts during a call made with INFO(11) > 0 and -C INFO(14) = 1. -C -C -C------INPUT - WHAT TO DO TO CONTINUE THE INTEGRATION ----------------- -C (CALLS AFTER THE FIRST) -C -C This code is organized so that subsequent calls to continue the -C integration involve little (if any) additional effort on your -C part. You must monitor the IDID parameter in order to determine -C what to do next. -C -C Recalling that the principal task of the code is to integrate -C from T to TOUT (the interval mode), usually all you will need -C to do is specify a new TOUT upon reaching the current TOUT. -C -C Do not alter any quantity not specifically permitted below. In -C particular do not alter NEQ, T, Y(*), YPRIME(*), RWORK(*), -C IWORK(*), or the differential equation in subroutine RES. Any -C such alteration constitutes a new problem and must be treated -C as such, i.e. you must start afresh. -C -C You cannot change from array to scalar error control or vice -C versa (INFO(2)), but you can change the size of the entries of -C RTOL or ATOL. Increasing a tolerance makes the equation easier -C to integrate. Decreasing a tolerance will make the equation -C harder to integrate and should generally be avoided. -C -C You can switch from the intermediate-output mode to the -C interval mode (INFO(3)) or vice versa at any time. -C -C If it has been necessary to prevent the integration from going -C past a point TSTOP (INFO(4), RWORK(1)), keep in mind that the -C code will not integrate to any TOUT beyond the currently -C specified TSTOP. Once TSTOP has been reached, you must change -C the value of TSTOP or set INFO(4) = 0. You may change INFO(4) -C or TSTOP at any time but you must supply the value of TSTOP in -C RWORK(1) whenever you set INFO(4) = 1. -C -C Do not change INFO(5), INFO(6), INFO(12-17) or their associated -C IWORK/RWORK locations unless you are going to restart the code. -C -C *** FOLLOWING A COMPLETED TASK *** -C -C If.. -C IDID = 1, call the code again to continue the integration -C another step in the direction of TOUT. -C -C IDID = 2 or 3, define a new TOUT and call the code again. -C TOUT must be different from T. You cannot change -C the direction of integration without restarting. -C -C IDID = 4, reset INFO(11) = 0 and call the code again to begin -C the integration. (If you leave INFO(11) > 0 and -C INFO(14) = 1, you may generate an infinite loop.) -C In this situation, the next call to DASPK is -C considered to be the first call for the problem, -C in that all initializations are done. -C -C *** FOLLOWING AN INTERRUPTED TASK *** -C -C To show the code that you realize the task was interrupted and -C that you want to continue, you must take appropriate action and -C set INFO(1) = 1. -C -C If.. -C IDID = -1, the code has taken about 500 steps. If you want to -C continue, set INFO(1) = 1 and call the code again. -C An additional 500 steps will be allowed. -C -C -C IDID = -2, the error tolerances RTOL, ATOL have been increased -C to values the code estimates appropriate for -C continuing. You may want to change them yourself. -C If you are sure you want to continue with relaxed -C error tolerances, set INFO(1) = 1 and call the code -C again. -C -C IDID = -3, a solution component is zero and you set the -C corresponding component of ATOL to zero. If you -C are sure you want to continue, you must first alter -C the error criterion to use positive values of ATOL -C for those components corresponding to zero solution -C components, then set INFO(1) = 1 and call the code -C again. -C -C IDID = -4 --- cannot occur with this code. -C -C IDID = -5, your JAC routine failed with the Krylov method. Check -C for errors in JAC and restart the integration. -C -C IDID = -6, repeated error test failures occurred on the last -C attempted step in DDASPK. A singularity in the -C solution may be present. If you are absolutely -C certain you want to continue, you should restart -C the integration. (Provide initial values of Y and -C YPRIME which are consistent.) -C -C IDID = -7, repeated convergence test failures occurred on the last -C attempted step in DDASPK. An inaccurate or ill- -C conditioned Jacobian or preconditioner may be the -C problem. If you are absolutely certain you want -C to continue, you should restart the integration. -C -C -C IDID = -8, the matrix of partial derivatives is singular, with -C the use of direct methods. Some of your equations -C may be redundant. DDASPK cannot solve the problem -C as stated. It is possible that the redundant -C equations could be removed, and then DDASPK could -C solve the problem. It is also possible that a -C solution to your problem either does not exist -C or is not unique. -C -C IDID = -9, DDASPK had multiple convergence test failures, preceded -C by multiple error test failures, on the last -C attempted step. It is possible that your problem is -C ill-posed and cannot be solved using this code. Or, -C there may be a discontinuity or a singularity in the -C solution. If you are absolutely certain you want to -C continue, you should restart the integration. -C -C IDID = -10, DDASPK had multiple convergence test failures -C because IRES was equal to -1. If you are -C absolutely certain you want to continue, you -C should restart the integration. -C -C IDID = -11, there was an unrecoverable error (IRES = -2) from RES -C inside the nonlinear system solver. Determine the -C cause before trying again. -C -C IDID = -12, DDASPK failed to compute the initial Y and YPRIME -C vectors. This could happen because the initial -C approximation to Y or YPRIME was not very good, or -C because no consistent values of these vectors exist. -C The problem could also be caused by an inaccurate or -C singular iteration matrix, or a poor preconditioner. -C -C IDID = -13, there was an unrecoverable error encountered inside -C your PSOL routine. Determine the cause before -C trying again. -C -C IDID = -14, the Krylov linear system solver failed to achieve -C convergence. This may be due to ill-conditioning -C in the iteration matrix, or a singularity in the -C preconditioner (if one is being used). -C Another possibility is that there is a better -C choice of Krylov parameters (see INFO(13)). -C Possibly the failure is caused by redundant equations -C in the system, or by inconsistent equations. -C In that case, reformulate the system to make it -C consistent and non-redundant. -C -C IDID = -15,..,-32 --- Cannot occur with this code. -C -C *** FOLLOWING A TERMINATED TASK *** -C -C If IDID = -33, you cannot continue the solution of this problem. -C An attempt to do so will result in your run being -C terminated. -C -C --------------------------------------------------------------------- -C -C***REFERENCES -C 1. L. R. Petzold, A Description of DASSL: A Differential/Algebraic -C System Solver, in Scientific Computing, R. S. Stepleman et al. -C (Eds.), North-Holland, Amsterdam, 1983, pp. 65-68. -C 2. K. E. Brenan, S. L. Campbell, and L. R. Petzold, Numerical -C Solution of Initial-Value Problems in Differential-Algebraic -C Equations, Elsevier, New York, 1989. -C 3. P. N. Brown and A. C. Hindmarsh, Reduced Storage Matrix Methods -C in Stiff ODE Systems, J. Applied Mathematics and Computation, -C 31 (1989), pp. 40-91. -C 4. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Using Krylov -C Methods in the Solution of Large-Scale Differential-Algebraic -C Systems, SIAM J. Sci. Comp., 15 (1994), pp. 1467-1488. -C 5. P. N. Brown, A. C. Hindmarsh, and L. R. Petzold, Consistent -C Initial Condition Calculation for Differential-Algebraic -C Systems, SIAM J. Sci. Comp. 19 (1998), pp. 1495-1512. -C -C***ROUTINES CALLED -C -C The following are all the subordinate routines used by DDASPK. -C -C DDASIC computes consistent initial conditions. -C DYYPNW updates Y and YPRIME in linesearch for initial condition -C calculation. -C DDSTP carries out one step of the integration. -C DCNSTR/DCNST0 check the current solution for constraint violations. -C DDAWTS sets error weight quantities. -C DINVWT tests and inverts the error weights. -C DDATRP performs interpolation to get an output solution. -C DDWNRM computes the weighted root-mean-square norm of a vector. -C D1MACH provides the unit roundoff of the computer. -C XERRWD/XSETF/XSETUN/IXSAV is a package to handle error messages. -C DDASID nonlinear equation driver to initialize Y and YPRIME using -C direct linear system solver methods. Interfaces to Newton -C solver (direct case). -C DNSID solves the nonlinear system for unknown initial values by -C modified Newton iteration and direct linear system methods. -C DLINSD carries out linesearch algorithm for initial condition -C calculation (direct case). -C DFNRMD calculates weighted norm of preconditioned residual in -C initial condition calculation (direct case). -C DNEDD nonlinear equation driver for direct linear system solver -C methods. Interfaces to Newton solver (direct case). -C DMATD assembles the iteration matrix (direct case). -C DNSD solves the associated nonlinear system by modified -C Newton iteration and direct linear system methods. -C DSLVD interfaces to linear system solver (direct case). -C DDASIK nonlinear equation driver to initialize Y and YPRIME using -C Krylov iterative linear system methods. Interfaces to -C Newton solver (Krylov case). -C DNSIK solves the nonlinear system for unknown initial values by -C Newton iteration and Krylov iterative linear system methods. -C DLINSK carries out linesearch algorithm for initial condition -C calculation (Krylov case). -C DFNRMK calculates weighted norm of preconditioned residual in -C initial condition calculation (Krylov case). -C DNEDK nonlinear equation driver for iterative linear system solver -C methods. Interfaces to Newton solver (Krylov case). -C DNSK solves the associated nonlinear system by Inexact Newton -C iteration and (linear) Krylov iteration. -C DSLVK interfaces to linear system solver (Krylov case). -C DSPIGM solves a linear system by SPIGMR algorithm. -C DATV computes matrix-vector product in Krylov algorithm. -C DORTH performs orthogonalization of Krylov basis vectors. -C DHEQR performs QR factorization of Hessenberg matrix. -C DHELS finds least-squares solution of Hessenberg linear system. -C DGEFA, DGESL, DGBFA, DGBSL are LINPACK routines for solving -C linear systems (dense or band direct methods). -C DAXPY, DCOPY, DDOT, DNRM2, DSCAL are Basic Linear Algebra (BLAS) -C routines. -C -C The routines called directly by DDASPK are: -C DCNST0, DDAWTS, DINVWT, D1MACH, DDWNRM, DDASIC, DDATRP, DDSTP, -C XERRWD -C -C***END PROLOGUE DDASPK -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL DONE, LAVL, LCFN, LCFL, LWARN - DIMENSION Y(*),YPRIME(*) - DIMENSION INFO(20) - DIMENSION RWORK(LRW),IWORK(LIW) - DIMENSION RTOL(*),ATOL(*) - DIMENSION RPAR(*),IPAR(*) - CHARACTER MSG*80 - EXTERNAL RES, JAC, PSOL, DDASID, DDASIK, DNEDD, DNEDK -C -C Set pointers into IWORK. -C - PARAMETER (LML=1, LMU=2, LMTYPE=4, - * LIWM=1, LMXORD=3, LJCALC=5, LPHASE=6, LK=7, LKOLD=8, - * LNS=9, LNSTL=10, LNST=11, LNRE=12, LNJE=13, LETF=14, LNCFN=15, - * LNCFL=16, LNIW=17, LNRW=18, LNNI=19, LNLI=20, LNPS=21, - * LNPD=22, LMITER=23, LMAXL=24, LKMP=25, LNRMAX=26, LLNWP=27, - * LLNIWP=28, LLOCWP=29, LLCIWP=30, LKPRIN=31, - * LMXNIT=32, LMXNJ=33, LMXNH=34, LLSOFF=35, LICNS=41) -C -C Set pointers into RWORK. -C - PARAMETER (LTSTOP=1, LHMAX=2, LH=3, LTN=4, LCJ=5, LCJOLD=6, - * LHOLD=7, LS=8, LROUND=9, LEPLI=10, LSQRN=11, LRSQRN=12, - * LEPCON=13, LSTOL=14, LEPIN=15, - * LALPHA=21, LBETA=27, LGAMMA=33, LPSI=39, LSIGMA=45, LDELTA=51) -C - SAVE LID, LENID, NONNEG, NCPHI -C -C -C***FIRST EXECUTABLE STATEMENT DDASPK -C -C - IF(INFO(1).NE.0) GO TO 100 -C -C----------------------------------------------------------------------- -C This block is executed for the initial call only. -C It contains checking of inputs and initializations. -C----------------------------------------------------------------------- -C -C First check INFO array to make sure all elements of INFO -C Are within the proper range. (INFO(1) is checked later, because -C it must be tested on every call.) ITEMP holds the location -C within INFO which may be out of range. -C - DO 10 I=2,9 - ITEMP = I - IF (INFO(I) .NE. 0 .AND. INFO(I) .NE. 1) GO TO 701 - 10 CONTINUE - ITEMP = 10 - IF(INFO(10).LT.0 .OR. INFO(10).GT.3) GO TO 701 - ITEMP = 11 - IF(INFO(11).LT.0 .OR. INFO(11).GT.2) GO TO 701 - DO 15 I=12,17 - ITEMP = I - IF (INFO(I) .NE. 0 .AND. INFO(I) .NE. 1) GO TO 701 - 15 CONTINUE - ITEMP = 18 - IF(INFO(18).LT.0 .OR. INFO(18).GT.2) GO TO 701 - -C -C Check NEQ to see if it is positive. -C - IF (NEQ .LE. 0) GO TO 702 -C -C Check and compute maximum order. -C - MXORD=5 - IF (INFO(9) .NE. 0) THEN - MXORD=IWORK(LMXORD) - IF (MXORD .LT. 1 .OR. MXORD .GT. 5) GO TO 703 - ENDIF - IWORK(LMXORD)=MXORD -C -C Set and/or check inputs for constraint checking (INFO(10) .NE. 0). -C Set values for ICNFLG, NONNEG, and pointer LID. -C - ICNFLG = 0 - NONNEG = 0 - LID = LICNS - IF (INFO(10) .EQ. 0) GO TO 20 - IF (INFO(10) .EQ. 1) THEN - ICNFLG = 1 - NONNEG = 0 - LID = LICNS + NEQ - ELSEIF (INFO(10) .EQ. 2) THEN - ICNFLG = 0 - NONNEG = 1 - ELSE - ICNFLG = 1 - NONNEG = 1 - LID = LICNS + NEQ - ENDIF -C - 20 CONTINUE -C -C Set and/or check inputs for Krylov solver (INFO(12) .NE. 0). -C If indicated, set default values for MAXL, KMP, NRMAX, and EPLI. -C Otherwise, verify inputs required for iterative solver. -C - IF (INFO(12) .EQ. 0) GO TO 25 -C - IWORK(LMITER) = INFO(12) - IF (INFO(13) .EQ. 0) THEN - IWORK(LMAXL) = MIN(5,NEQ) - IWORK(LKMP) = IWORK(LMAXL) - IWORK(LNRMAX) = 5 - RWORK(LEPLI) = 0.05D0 - ELSE - IF(IWORK(LMAXL) .LT. 1 .OR. IWORK(LMAXL) .GT. NEQ) GO TO 720 - IF(IWORK(LKMP) .LT. 1 .OR. IWORK(LKMP) .GT. IWORK(LMAXL)) - 1 GO TO 721 - IF(IWORK(LNRMAX) .LT. 0) GO TO 722 - IF(RWORK(LEPLI).LE.0.0D0 .OR. RWORK(LEPLI).GE.1.0D0)GO TO 723 - ENDIF -C - 25 CONTINUE -C -C Set and/or check controls for the initial condition calculation -C (INFO(11) .GT. 0). If indicated, set default values. -C Otherwise, verify inputs required for iterative solver. -C - IF (INFO(11) .EQ. 0) GO TO 30 - IF (INFO(17) .EQ. 0) THEN - IWORK(LMXNIT) = 5 - IF (INFO(12) .GT. 0) IWORK(LMXNIT) = 15 - IWORK(LMXNJ) = 6 - IF (INFO(12) .GT. 0) IWORK(LMXNJ) = 2 - IWORK(LMXNH) = 5 - IWORK(LLSOFF) = 0 - RWORK(LEPIN) = 0.01D0 - ELSE - IF (IWORK(LMXNIT) .LE. 0) GO TO 725 - IF (IWORK(LMXNJ) .LE. 0) GO TO 725 - IF (IWORK(LMXNH) .LE. 0) GO TO 725 - LSOFF = IWORK(LLSOFF) - IF (LSOFF .LT. 0 .OR. LSOFF .GT. 1) GO TO 725 - IF (RWORK(LEPIN) .LE. 0.0D0) GO TO 725 - ENDIF -C - 30 CONTINUE -C -C Below is the computation and checking of the work array lengths -C LENIW and LENRW, using direct methods (INFO(12) = 0) or -C the Krylov methods (INFO(12) = 1). -C - LENIC = 0 - IF (INFO(10) .EQ. 1 .OR. INFO(10) .EQ. 3) LENIC = NEQ - LENID = 0 - IF (INFO(11) .EQ. 1 .OR. INFO(16) .EQ. 1) LENID = NEQ - IF (INFO(12) .EQ. 0) THEN -C -C Compute MTYPE, etc. Check ML and MU. -C - NCPHI = MAX(MXORD + 1, 4) - IF(INFO(6).EQ.0) THEN - LENPD = NEQ**2 - LENRW = 50 + (NCPHI+3)*NEQ + LENPD - IF(INFO(5).EQ.0) THEN - IWORK(LMTYPE)=2 - ELSE - IWORK(LMTYPE)=1 - ENDIF - ELSE - IF(IWORK(LML).LT.0.OR.IWORK(LML).GE.NEQ)GO TO 717 - IF(IWORK(LMU).LT.0.OR.IWORK(LMU).GE.NEQ)GO TO 718 - LENPD=(2*IWORK(LML)+IWORK(LMU)+1)*NEQ - IF(INFO(5).EQ.0) THEN - IWORK(LMTYPE)=5 - MBAND=IWORK(LML)+IWORK(LMU)+1 - MSAVE=(NEQ/MBAND)+1 - LENRW = 50 + (NCPHI+3)*NEQ + LENPD + 2*MSAVE - ELSE - IWORK(LMTYPE)=4 - LENRW = 50 + (NCPHI+3)*NEQ + LENPD - ENDIF - ENDIF -C -C Compute LENIW, LENWP, LENIWP. -C - LENIW = 40 + LENIC + LENID + NEQ - LENWP = 0 - LENIWP = 0 -C - ELSE IF (INFO(12) .EQ. 1) THEN - NCPHI = MXORD + 1 - MAXL = IWORK(LMAXL) - LENWP = IWORK(LLNWP) - LENIWP = IWORK(LLNIWP) - LENPD = (MAXL+3+MIN0(1,MAXL-IWORK(LKMP)))*NEQ - 1 + (MAXL+3)*MAXL + 1 + LENWP - LENRW = 50 + (MXORD+5)*NEQ + LENPD - LENIW = 40 + LENIC + LENID + LENIWP -C - ENDIF - IF(INFO(16) .NE. 0) LENRW = LENRW + NEQ -C -C Check lengths of RWORK and IWORK. -C - IWORK(LNIW)=LENIW - IWORK(LNRW)=LENRW - IWORK(LNPD)=LENPD - IWORK(LLOCWP) = LENPD-LENWP+1 - IF(LRW.LT.LENRW)GO TO 704 - IF(LIW.LT.LENIW)GO TO 705 -C -C Check ICNSTR for legality. -C - IF (LENIC .GT. 0) THEN - DO 40 I = 1,NEQ - ICI = IWORK(LICNS-1+I) - IF (ICI .LT. -2 .OR. ICI .GT. 2) GO TO 726 - 40 CONTINUE - ENDIF -C -C Check Y for consistency with constraints. -C - IF (LENIC .GT. 0) THEN - CALL DCNST0(NEQ,Y,IWORK(LICNS),IRET) - IF (IRET .NE. 0) GO TO 727 - ENDIF -C -C Check ID for legality and set INDEX = 0 or 1. -C - INDEX = 1 - IF (LENID .GT. 0) THEN - INDEX = 0 - DO 50 I = 1,NEQ - IDI = IWORK(LID-1+I) - IF (IDI .NE. 1 .AND. IDI .NE. -1) GO TO 724 - IF (IDI .EQ. -1) INDEX = 1 - 50 CONTINUE - ENDIF -C -C Check to see that TOUT is different from T. -C - IF(TOUT .EQ. T)GO TO 719 -C -C Check HMAX. -C - IF(INFO(7) .NE. 0) THEN - HMAX = RWORK(LHMAX) - IF (HMAX .LE. 0.0D0) GO TO 710 - ENDIF -C -C Initialize counters and other flags. -C - IWORK(LNST)=0 - IWORK(LNRE)=0 - IWORK(LNJE)=0 - IWORK(LETF)=0 - IWORK(LNCFN)=0 - IWORK(LNNI)=0 - IWORK(LNLI)=0 - IWORK(LNPS)=0 - IWORK(LNCFL)=0 - IWORK(LKPRIN)=INFO(18) - IDID=1 - GO TO 200 -C -C----------------------------------------------------------------------- -C This block is for continuation calls only. -C Here we check INFO(1), and if the last step was interrupted, -C we check whether appropriate action was taken. -C----------------------------------------------------------------------- -C -100 CONTINUE - IF(INFO(1).EQ.1)GO TO 110 - ITEMP = 1 - IF(INFO(1).NE.-1)GO TO 701 -C -C If we are here, the last step was interrupted by an error -C condition from DDSTP, and appropriate action was not taken. -C This is a fatal error. -C - MSG = 'DASPK-- THE LAST STEP TERMINATED WITH A NEGATIVE' - CALL XERRWD(MSG,49,201,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- VALUE (=I1) OF IDID AND NO APPROPRIATE' - CALL XERRWD(MSG,47,202,0,1,IDID,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- ACTION WAS TAKEN. RUN TERMINATED' - CALL XERRWD(MSG,41,203,1,0,0,0,0,0.0D0,0.0D0) - RETURN -110 CONTINUE -C -C----------------------------------------------------------------------- -C This block is executed on all calls. -C -C Counters are saved for later checks of performance. -C Then the error tolerance parameters are checked, and the -C work array pointers are set. -C----------------------------------------------------------------------- -C -200 CONTINUE -C -C Save counters for use later. -C - IWORK(LNSTL)=IWORK(LNST) - NLI0 = IWORK(LNLI) - NNI0 = IWORK(LNNI) - NCFN0 = IWORK(LNCFN) - NCFL0 = IWORK(LNCFL) - NWARN = 0 -C -C Check RTOL and ATOL. -C - NZFLG = 0 - RTOLI = RTOL(1) - ATOLI = ATOL(1) - DO 210 I=1,NEQ - IF (INFO(2) .EQ. 1) RTOLI = RTOL(I) - IF (INFO(2) .EQ. 1) ATOLI = ATOL(I) - IF (RTOLI .GT. 0.0D0 .OR. ATOLI .GT. 0.0D0) NZFLG = 1 - IF (RTOLI .LT. 0.0D0) GO TO 706 - IF (ATOLI .LT. 0.0D0) GO TO 707 -210 CONTINUE - IF (NZFLG .EQ. 0) GO TO 708 -C -C Set pointers to RWORK and IWORK segments. -C For direct methods, SAVR is not used. -C - IWORK(LLCIWP) = LID + LENID - LSAVR = LDELTA - IF (INFO(12) .NE. 0) LSAVR = LDELTA + NEQ - LE = LSAVR + NEQ - LWT = LE + NEQ - LVT = LWT - IF (INFO(16) .NE. 0) LVT = LWT + NEQ - LPHI = LVT + NEQ - LWM = LPHI + NCPHI*NEQ - IF (INFO(1) .EQ. 1) GO TO 400 -C -C----------------------------------------------------------------------- -C This block is executed on the initial call only. -C Set the initial step size, the error weight vector, and PHI. -C Compute unknown initial components of Y and YPRIME, if requested. -C----------------------------------------------------------------------- -C -300 CONTINUE - TN=T - IDID=1 -C -C Set error weight array WT and altered weight array VT. -C - CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) - CALL DINVWT(NEQ,RWORK(LWT),IER) - IF (IER .NE. 0) GO TO 713 - IF (INFO(16) .NE. 0) THEN - DO 305 I = 1, NEQ - 305 RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) - ENDIF -C -C Compute unit roundoff and HMIN. -C - UROUND = D1MACH(4) - RWORK(LROUND) = UROUND - HMIN = 4.0D0*UROUND*MAX(ABS(T),ABS(TOUT)) -C -C Set/check STPTOL control for initial condition calculation. -C - IF (INFO(11) .NE. 0) THEN - IF( INFO(17) .EQ. 0) THEN - RWORK(LSTOL) = UROUND**.6667D0 - ELSE - IF (RWORK(LSTOL) .LE. 0.0D0) GO TO 725 - ENDIF - ENDIF -C -C Compute EPCON and square root of NEQ and its reciprocal, used -C inside iterative solver. -C - RWORK(LEPCON) = 0.33D0 - FLOATN = NEQ - RWORK(LSQRN) = SQRT(FLOATN) - RWORK(LRSQRN) = 1.D0/RWORK(LSQRN) -C -C Check initial interval to see that it is long enough. -C - TDIST = ABS(TOUT - T) - IF(TDIST .LT. HMIN) GO TO 714 -C -C Check H0, if this was input. -C - IF (INFO(8) .EQ. 0) GO TO 310 - H0 = RWORK(LH) - IF ((TOUT - T)*H0 .LT. 0.0D0) GO TO 711 - IF (H0 .EQ. 0.0D0) GO TO 712 - GO TO 320 -310 CONTINUE -C -C Compute initial stepsize, to be used by either -C DDSTP or DDASIC, depending on INFO(11). -C - H0 = 0.001D0*TDIST - YPNORM = DDWNRM(NEQ,YPRIME,RWORK(LVT),RPAR,IPAR) - IF (YPNORM .GT. 0.5D0/H0) H0 = 0.5D0/YPNORM - H0 = SIGN(H0,TOUT-T) -C -C Adjust H0 if necessary to meet HMAX bound. -C -320 IF (INFO(7) .EQ. 0) GO TO 330 - RH = ABS(H0)/RWORK(LHMAX) - IF (RH .GT. 1.0D0) H0 = H0/RH -C -C Check against TSTOP, if applicable. -C -330 IF (INFO(4) .EQ. 0) GO TO 340 - TSTOP = RWORK(LTSTOP) - write(*,*) 'tstop = ',tstop - IF ((TSTOP - T)*H0 .LT. 0.0D0) GO TO 715 - IF ((T + H0 - TSTOP)*H0 .GT. 0.0D0) H0 = TSTOP - T - IF ((TSTOP - TOUT)*H0 .LT. 0.0D0) GO TO 709 -C -340 IF (INFO(11) .EQ. 0) GO TO 370 -C -C Compute unknown components of initial Y and YPRIME, depending -C on INFO(11) and INFO(12). INFO(12) represents the nonlinear -C solver type (direct/Krylov). Pass the name of the specific -C nonlinear solver, depending on INFO(12). The location of the work -C arrays SAVR, YIC, YPIC, PWK also differ in the two cases. -C For use in stopping tests, pass TSCALE = TDIST if INDEX = 0. -C - NWT = 1 - EPCONI = RWORK(LEPIN)*RWORK(LEPCON) - TSCALE = 0.0D0 - IF (INDEX .EQ. 0) TSCALE = TDIST -350 IF (INFO(12) .EQ. 0) THEN - LYIC = LPHI + 2*NEQ - LYPIC = LYIC + NEQ - LPWK = LYPIC - CALL DDASIC(TN,Y,YPRIME,NEQ,INFO(11),IWORK(LID), - * RES,JAC,PSOL,H0,TSCALE,RWORK(LWT),NWT,IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), - * RWORK(LYIC),RWORK(LYPIC),RWORK(LPWK),RWORK(LWM),IWORK(LIWM), - * RWORK(LROUND),RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), - * EPCONI,RWORK(LSTOL),INFO(15),ICNFLG,IWORK(LICNS),DDASID) - ELSE IF (INFO(12) .EQ. 1) THEN - LYIC = LWM - LYPIC = LYIC + NEQ - LPWK = LYPIC + NEQ - CALL DDASIC(TN,Y,YPRIME,NEQ,INFO(11),IWORK(LID), - * RES,JAC,PSOL,H0,TSCALE,RWORK(LWT),NWT,IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), - * RWORK(LYIC),RWORK(LYPIC),RWORK(LPWK),RWORK(LWM),IWORK(LIWM), - * RWORK(LROUND),RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), - * EPCONI,RWORK(LSTOL),INFO(15),ICNFLG,IWORK(LICNS),DDASIK) - ENDIF -C - IF (IDID .LT. 0) GO TO 600 -C -C DDASIC was successful. If this was the first call to DDASIC, -C update the WT array (with the current Y) and call it again. -C - IF (NWT .EQ. 2) GO TO 355 - NWT = 2 - CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) - CALL DINVWT(NEQ,RWORK(LWT),IER) - IF (IER .NE. 0) GO TO 713 - GO TO 350 -C -C If INFO(14) = 1, return now with IDID = 4. -C -355 IF (INFO(14) .EQ. 1) THEN - IDID = 4 - H = H0 - IF (INFO(11) .EQ. 1) RWORK(LHOLD) = H0 - GO TO 590 - ENDIF -C -C Update the WT and VT arrays one more time, with the new Y. -C - CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,Y,RWORK(LWT),RPAR,IPAR) - CALL DINVWT(NEQ,RWORK(LWT),IER) - IF (IER .NE. 0) GO TO 713 - IF (INFO(16) .NE. 0) THEN - DO 357 I = 1, NEQ - 357 RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) - ENDIF -C -C Reset the initial stepsize to be used by DDSTP. -C Use H0, if this was input. Otherwise, recompute H0, -C and adjust it if necessary to meet HMAX bound. -C - IF (INFO(8) .NE. 0) THEN - H0 = RWORK(LH) - GO TO 360 - ENDIF -C - H0 = 0.001D0*TDIST - YPNORM = DDWNRM(NEQ,YPRIME,RWORK(LVT),RPAR,IPAR) - IF (YPNORM .GT. 0.5D0/H0) H0 = 0.5D0/YPNORM - H0 = SIGN(H0,TOUT-T) -C -360 IF (INFO(7) .NE. 0) THEN - RH = ABS(H0)/RWORK(LHMAX) - IF (RH .GT. 1.0D0) H0 = H0/RH - ENDIF -C -C Check against TSTOP, if applicable. -C - IF (INFO(4) .NE. 0) THEN - TSTOP = RWORK(LTSTOP) - write(*,*) 'tstop = ',tstop - IF ((T + H0 - TSTOP)*H0 .GT. 0.0D0) H0 = TSTOP - T - ENDIF -C -C Load H and RWORK(LH) with H0. -C -370 H = H0 - RWORK(LH) = H -C -C Load Y and H*YPRIME into PHI(*,1) and PHI(*,2). -C - ITEMP = LPHI + NEQ - DO 380 I = 1,NEQ - RWORK(LPHI + I - 1) = Y(I) -380 RWORK(ITEMP + I - 1) = H*YPRIME(I) -C - GO TO 500 -C -C----------------------------------------------------------------------- -C This block is for continuation calls only. -C Its purpose is to check stop conditions before taking a step. -C Adjust H if necessary to meet HMAX bound. -C----------------------------------------------------------------------- -C -400 CONTINUE - UROUND=RWORK(LROUND) - DONE = .FALSE. - TN=RWORK(LTN) - H=RWORK(LH) - IF(INFO(7) .EQ. 0) GO TO 410 - RH = ABS(H)/RWORK(LHMAX) - IF(RH .GT. 1.0D0) H = H/RH -410 CONTINUE - IF(T .EQ. TOUT) GO TO 719 - IF((T - TOUT)*H .GT. 0.0D0) GO TO 711 - IF(INFO(4) .EQ. 1) GO TO 430 - IF(INFO(3) .EQ. 1) GO TO 420 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 490 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -420 IF((TN-T)*H .LE. 0.0D0) GO TO 490 - IF((TN - TOUT)*H .GE. 0.0D0) GO TO 425 - CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TN - IDID = 1 - DONE = .TRUE. - GO TO 490 -425 CONTINUE - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -430 IF(INFO(3) .EQ. 1) GO TO 440 - TSTOP=RWORK(LTSTOP) - write(*,*) 'tstop = ',tstop - IF((TN-TSTOP)*H.GT.0.0D0) GO TO 715 - IF((TSTOP-TOUT)*H.LT.0.0D0)GO TO 709 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 450 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -440 TSTOP = RWORK(LTSTOP) - write(*,*) 'tstop = ',tstop - IF((TN-TSTOP)*H .GT. 0.0D0) GO TO 715 - IF((TSTOP-TOUT)*H .LT. 0.0D0) GO TO 709 - IF((TN-T)*H .LE. 0.0D0) GO TO 450 - IF((TN - TOUT)*H .GE. 0.0D0) GO TO 445 - CALL DDATRP(TN,TN,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TN - IDID = 1 - DONE = .TRUE. - GO TO 490 -445 CONTINUE - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - T = TOUT - IDID = 3 - DONE = .TRUE. - GO TO 490 -450 CONTINUE -C -C Check whether we are within roundoff of TSTOP. -C - IF(ABS(TN-TSTOP).GT.100.0D0*UROUND* - * (ABS(TN)+ABS(H)))GO TO 460 - CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ,IWORK(LKOLD), - * RWORK(LPHI),RWORK(LPSI)) - IDID=2 - T=TSTOP - DONE = .TRUE. - GO TO 490 -460 TNEXT=TN+H - IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 490 - H=TSTOP-TN - RWORK(LH)=H -C -490 IF (DONE) GO TO 590 -C -C----------------------------------------------------------------------- -C The next block contains the call to the one-step integrator DDSTP. -C This is a looping point for the integration steps. -C Check for too many steps. -C Check for poor Newton/Krylov performance. -C Update WT. Check for too much accuracy requested. -C Compute minimum stepsize. -C----------------------------------------------------------------------- -C -500 CONTINUE -C -C Check for too many steps. -C - IF((IWORK(LNST)-IWORK(LNSTL)).LT.500) GO TO 505 - IDID=-1 - GO TO 527 -C -C Check for poor Newton/Krylov performance. -C -505 IF (INFO(12) .EQ. 0) GO TO 510 - NSTD = IWORK(LNST) - IWORK(LNSTL) - NNID = IWORK(LNNI) - NNI0 - IF (NSTD .LT. 10 .OR. NNID .EQ. 0) GO TO 510 - AVLIN = REAL(IWORK(LNLI) - NLI0)/REAL(NNID) - RCFN = REAL(IWORK(LNCFN) - NCFN0)/REAL(NSTD) - RCFL = REAL(IWORK(LNCFL) - NCFL0)/REAL(NNID) - FMAXL = IWORK(LMAXL) - LAVL = AVLIN .GT. FMAXL - LCFN = RCFN .GT. 0.9D0 - LCFL = RCFL .GT. 0.9D0 - LWARN = LAVL .OR. LCFN .OR. LCFL - IF (.NOT.LWARN) GO TO 510 - NWARN = NWARN + 1 - IF (NWARN .GT. 10) GO TO 510 - IF (LAVL) THEN - MSG = 'DASPK-- Warning. Poor iterative algorithm performance ' - CALL XERRWD (MSG, 56, 501, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG = ' at T = R1. Average no. of linear iterations = R2 ' - CALL XERRWD (MSG, 56, 501, 0, 0, 0, 0, 2, TN, AVLIN) - ENDIF - IF (LCFN) THEN - MSG = 'DASPK-- Warning. Poor iterative algorithm performance ' - CALL XERRWD (MSG, 56, 502, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG = ' at T = R1. Nonlinear convergence failure rate = R2' - CALL XERRWD (MSG, 56, 502, 0, 0, 0, 0, 2, TN, RCFN) - ENDIF - IF (LCFL) THEN - MSG = 'DASPK-- Warning. Poor iterative algorithm performance ' - CALL XERRWD (MSG, 56, 503, 0, 0, 0, 0, 0, 0.0D0, 0.0D0) - MSG = ' at T = R1. Linear convergence failure rate = R2 ' - CALL XERRWD (MSG, 56, 503, 0, 0, 0, 0, 2, TN, RCFL) - ENDIF -C -C Update WT and VT, if this is not the first call. -C -510 CALL DDAWTS(NEQ,INFO(2),RTOL,ATOL,RWORK(LPHI),RWORK(LWT), - * RPAR,IPAR) - CALL DINVWT(NEQ,RWORK(LWT),IER) - IF (IER .NE. 0) THEN - IDID = -3 - GO TO 527 - ENDIF - IF (INFO(16) .NE. 0) THEN - DO 515 I = 1, NEQ - 515 RWORK(LVT+I-1) = MAX(IWORK(LID+I-1),0)*RWORK(LWT+I-1) - ENDIF -C -C Test for too much accuracy requested. -C - R = DDWNRM(NEQ,RWORK(LPHI),RWORK(LWT),RPAR,IPAR)*100.0D0*UROUND - IF (R .LE. 1.0D0) GO TO 525 -C -C Multiply RTOL and ATOL by R and return. -C - IF(INFO(2).EQ.1)GO TO 523 - RTOL(1)=R*RTOL(1) - ATOL(1)=R*ATOL(1) - IDID=-2 - GO TO 527 -523 DO 524 I=1,NEQ - RTOL(I)=R*RTOL(I) -524 ATOL(I)=R*ATOL(I) - IDID=-2 - GO TO 527 -525 CONTINUE -C -C Compute minimum stepsize. -C - HMIN=4.0D0*UROUND*MAX(ABS(TN),ABS(TOUT)) -C -C Test H vs. HMAX - IF (INFO(7) .NE. 0) THEN - RH = ABS(H)/RWORK(LHMAX) - IF (RH .GT. 1.0D0) H = H/RH - ENDIF -C -C Call the one-step integrator. -C Note that INFO(12) represents the nonlinear solver type. -C Pass the required nonlinear solver, depending upon INFO(12). -C - IF (INFO(12) .EQ. 0) THEN - CALL DDSTP(TN,Y,YPRIME,NEQ, - * RES,JAC,PSOL,H,RWORK(LWT),RWORK(LVT),INFO(1),IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), - * RWORK(LWM),IWORK(LIWM), - * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), - * RWORK(LPSI),RWORK(LSIGMA), - * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),RWORK(LS),HMIN, - * RWORK(LROUND), RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), - * RWORK(LEPCON), IWORK(LPHASE),IWORK(LJCALC),INFO(15), - * IWORK(LK), IWORK(LKOLD),IWORK(LNS),NONNEG,INFO(12), - * DNEDD) - ELSE IF (INFO(12) .EQ. 1) THEN - CALL DDSTP(TN,Y,YPRIME,NEQ, - * RES,JAC,PSOL,H,RWORK(LWT),RWORK(LVT),INFO(1),IDID,RPAR,IPAR, - * RWORK(LPHI),RWORK(LSAVR),RWORK(LDELTA),RWORK(LE), - * RWORK(LWM),IWORK(LIWM), - * RWORK(LALPHA),RWORK(LBETA),RWORK(LGAMMA), - * RWORK(LPSI),RWORK(LSIGMA), - * RWORK(LCJ),RWORK(LCJOLD),RWORK(LHOLD),RWORK(LS),HMIN, - * RWORK(LROUND), RWORK(LEPLI),RWORK(LSQRN),RWORK(LRSQRN), - * RWORK(LEPCON), IWORK(LPHASE),IWORK(LJCALC),INFO(15), - * IWORK(LK), IWORK(LKOLD),IWORK(LNS),NONNEG,INFO(12), - * DNEDK) - ENDIF -C -527 IF(IDID.LT.0)GO TO 600 -C -C----------------------------------------------------------------------- -C This block handles the case of a successful return from DDSTP -C (IDID=1). Test for stop conditions. -C----------------------------------------------------------------------- -C - IF(INFO(4).NE.0)GO TO 540 - IF(INFO(3).NE.0)GO TO 530 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 500 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=3 - T=TOUT - GO TO 580 -530 IF((TN-TOUT)*H.GE.0.0D0)GO TO 535 - T=TN - IDID=1 - GO TO 580 -535 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=3 - T=TOUT - GO TO 580 -540 IF(INFO(3).NE.0)GO TO 550 - IF((TN-TOUT)*H.LT.0.0D0)GO TO 542 - CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID=3 - GO TO 580 -542 IF(ABS(TN-TSTOP).LE.100.0D0*UROUND* - * (ABS(TN)+ABS(H)))GO TO 545 - TNEXT=TN+H - IF((TNEXT-TSTOP)*H.LE.0.0D0)GO TO 500 - H=TSTOP-TN - GO TO 500 -545 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=2 - T=TSTOP - GO TO 580 -550 IF((TN-TOUT)*H.GE.0.0D0)GO TO 555 - IF(ABS(TN-TSTOP).LE.100.0D0*UROUND*(ABS(TN)+ABS(H)))GO TO 552 - T=TN - IDID=1 - GO TO 580 -552 CALL DDATRP(TN,TSTOP,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - IDID=2 - T=TSTOP - GO TO 580 -555 CALL DDATRP(TN,TOUT,Y,YPRIME,NEQ, - * IWORK(LKOLD),RWORK(LPHI),RWORK(LPSI)) - T=TOUT - IDID=3 -580 CONTINUE -C -C----------------------------------------------------------------------- -C All successful returns from DDASPK are made from this block. -C----------------------------------------------------------------------- -C -590 CONTINUE - RWORK(LTN)=TN - RWORK(LH)=H - RETURN -C -C----------------------------------------------------------------------- -C This block handles all unsuccessful returns other than for -C illegal input. -C----------------------------------------------------------------------- -C -600 CONTINUE - ITEMP = -IDID - GO TO (610,620,630,700,655,640,650,660,670,675, - * 680,685,690,695), ITEMP -C -C The maximum number of steps was taken before -C reaching tout. -C -610 MSG = 'DASPK-- AT CURRENT T (=R1) 500 STEPS' - CALL XERRWD(MSG,38,610,0,0,0,0,1,TN,0.0D0) - MSG = 'DASPK-- TAKEN ON THIS CALL BEFORE REACHING TOUT' - CALL XERRWD(MSG,48,611,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Too much accuracy for machine precision. -C -620 MSG = 'DASPK-- AT T (=R1) TOO MUCH ACCURACY REQUESTED' - CALL XERRWD(MSG,47,620,0,0,0,0,1,TN,0.0D0) - MSG = 'DASPK-- FOR PRECISION OF MACHINE. RTOL AND ATOL' - CALL XERRWD(MSG,48,621,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- WERE INCREASED TO APPROPRIATE VALUES' - CALL XERRWD(MSG,45,622,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C WT(I) .LE. 0.0D0 for some I (not at start of problem). -C -630 MSG = 'DASPK-- AT T (=R1) SOME ELEMENT OF WT' - CALL XERRWD(MSG,38,630,0,0,0,0,1,TN,0.0D0) - MSG = 'DASPK-- HAS BECOME .LE. 0.0' - CALL XERRWD(MSG,28,631,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Error test failed repeatedly or with H=HMIN. -C -640 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,640,0,0,0,0,2,TN,H) - MSG='DASPK-- ERROR TEST FAILED REPEATEDLY OR WITH ABS(H)=HMIN' - CALL XERRWD(MSG,57,641,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Nonlinear solver failed to converge repeatedly or with H=HMIN. -C -650 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,650,0,0,0,0,2,TN,H) - MSG = 'DASPK-- NONLINEAR SOLVER FAILED TO CONVERGE' - CALL XERRWD(MSG,44,651,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- REPEATEDLY OR WITH ABS(H)=HMIN' - CALL XERRWD(MSG,40,652,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C The preconditioner had repeated failures. -C -655 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,655,0,0,0,0,2,TN,H) - MSG = 'DASPK-- PRECONDITIONER HAD REPEATED FAILURES.' - CALL XERRWD(MSG,46,656,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C The iteration matrix is singular. -C -660 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,660,0,0,0,0,2,TN,H) - MSG = 'DASPK-- ITERATION MATRIX IS SINGULAR.' - CALL XERRWD(MSG,38,661,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Nonlinear system failure preceded by error test failures. -C -670 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,670,0,0,0,0,2,TN,H) - MSG = 'DASPK-- NONLINEAR SOLVER COULD NOT CONVERGE.' - CALL XERRWD(MSG,45,671,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- ALSO, THE ERROR TEST FAILED REPEATEDLY.' - CALL XERRWD(MSG,49,672,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Nonlinear system failure because IRES = -1. -C -675 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,675,0,0,0,0,2,TN,H) - MSG = 'DASPK-- NONLINEAR SYSTEM SOLVER COULD NOT CONVERGE' - CALL XERRWD(MSG,51,676,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- BECAUSE IRES WAS EQUAL TO MINUS ONE' - CALL XERRWD(MSG,44,677,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Failure because IRES = -2. -C -680 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2)' - CALL XERRWD(MSG,40,680,0,0,0,0,2,TN,H) - MSG = 'DASPK-- IRES WAS EQUAL TO MINUS TWO' - CALL XERRWD(MSG,36,681,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Failed to compute initial YPRIME. -C -685 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,685,0,0,0,0,0,0.0D0,0.0D0) - MSG = 'DASPK-- INITIAL (Y,YPRIME) COULD NOT BE COMPUTED' - CALL XERRWD(MSG,49,686,0,0,0,0,2,TN,H0) - GO TO 700 -C -C Failure because IER was negative from PSOL. -C -690 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2)' - CALL XERRWD(MSG,40,690,0,0,0,0,2,TN,H) - MSG = 'DASPK-- IER WAS NEGATIVE FROM PSOL' - CALL XERRWD(MSG,35,691,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C Failure because the linear system solver could not converge. -C -695 MSG = 'DASPK-- AT T (=R1) AND STEPSIZE H (=R2) THE' - CALL XERRWD(MSG,44,695,0,0,0,0,2,TN,H) - MSG = 'DASPK-- LINEAR SYSTEM SOLVER COULD NOT CONVERGE.' - CALL XERRWD(MSG,50,696,0,0,0,0,0,0.0D0,0.0D0) - GO TO 700 -C -C -700 CONTINUE - INFO(1)=-1 - T=TN - RWORK(LTN)=TN - RWORK(LH)=H - RETURN -C -C----------------------------------------------------------------------- -C This block handles all error returns due to illegal input, -C as detected before calling DDSTP. -C First the error message routine is called. If this happens -C twice in succession, execution is terminated. -C----------------------------------------------------------------------- -C -701 MSG = 'DASPK-- ELEMENT (=I1) OF INFO VECTOR IS NOT VALID' - CALL XERRWD(MSG,50,1,0,1,ITEMP,0,0,0.0D0,0.0D0) - GO TO 750 -702 MSG = 'DASPK-- NEQ (=I1) .LE. 0' - CALL XERRWD(MSG,25,2,0,1,NEQ,0,0,0.0D0,0.0D0) - GO TO 750 -703 MSG = 'DASPK-- MAXORD (=I1) NOT IN RANGE' - CALL XERRWD(MSG,34,3,0,1,MXORD,0,0,0.0D0,0.0D0) - GO TO 750 -704 MSG='DASPK-- RWORK LENGTH NEEDED, LENRW (=I1), EXCEEDS LRW (=I2)' - CALL XERRWD(MSG,60,4,0,2,LENRW,LRW,0,0.0D0,0.0D0) - GO TO 750 -705 MSG='DASPK-- IWORK LENGTH NEEDED, LENIW (=I1), EXCEEDS LIW (=I2)' - CALL XERRWD(MSG,60,5,0,2,LENIW,LIW,0,0.0D0,0.0D0) - GO TO 750 -706 MSG = 'DASPK-- SOME ELEMENT OF RTOL IS .LT. 0' - CALL XERRWD(MSG,39,6,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -707 MSG = 'DASPK-- SOME ELEMENT OF ATOL IS .LT. 0' - CALL XERRWD(MSG,39,7,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -708 MSG = 'DASPK-- ALL ELEMENTS OF RTOL AND ATOL ARE ZERO' - CALL XERRWD(MSG,47,8,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -709 MSG='DASPK-- INFO(4) = 1 AND TSTOP (=R1) BEHIND TOUT (=R2)' - CALL XERRWD(MSG,54,9,0,0,0,0,2,TSTOP,TOUT) - GO TO 750 -710 MSG = 'DASPK-- HMAX (=R1) .LT. 0.0' - CALL XERRWD(MSG,28,10,0,0,0,0,1,HMAX,0.0D0) - GO TO 750 -711 MSG = 'DASPK-- TOUT (=R1) BEHIND T (=R2)' - CALL XERRWD(MSG,34,11,0,0,0,0,2,TOUT,T) - GO TO 750 -712 MSG = 'DASPK-- INFO(8)=1 AND H0=0.0' - CALL XERRWD(MSG,29,12,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -713 MSG = 'DASPK-- SOME ELEMENT OF WT IS .LE. 0.0' - CALL XERRWD(MSG,39,13,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -714 MSG='DASPK-- TOUT (=R1) TOO CLOSE TO T (=R2) TO START INTEGRATION' - CALL XERRWD(MSG,60,14,0,0,0,0,2,TOUT,T) - GO TO 750 -715 MSG = 'DASPK-- INFO(4)=1 AND TSTOP (=R1) BEHIND T (=R2)' - CALL XERRWD(MSG,49,15,0,0,0,0,2,TSTOP,T) - GO TO 750 -717 MSG = 'DASPK-- ML (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ' - CALL XERRWD(MSG,52,17,0,1,IWORK(LML),0,0,0.0D0,0.0D0) - GO TO 750 -718 MSG = 'DASPK-- MU (=I1) ILLEGAL. EITHER .LT. 0 OR .GT. NEQ' - CALL XERRWD(MSG,52,18,0,1,IWORK(LMU),0,0,0.0D0,0.0D0) - GO TO 750 -719 MSG = 'DASPK-- TOUT (=R1) IS EQUAL TO T (=R2)' - CALL XERRWD(MSG,39,19,0,0,0,0,2,TOUT,T) - GO TO 750 -720 MSG = 'DASPK-- MAXL (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. NEQ' - CALL XERRWD(MSG,54,20,0,1,IWORK(LMAXL),0,0,0.0D0,0.0D0) - GO TO 750 -721 MSG = 'DASPK-- KMP (=I1) ILLEGAL. EITHER .LT. 1 OR .GT. MAXL' - CALL XERRWD(MSG,54,21,0,1,IWORK(LKMP),0,0,0.0D0,0.0D0) - GO TO 750 -722 MSG = 'DASPK-- NRMAX (=I1) ILLEGAL. .LT. 0' - CALL XERRWD(MSG,36,22,0,1,IWORK(LNRMAX),0,0,0.0D0,0.0D0) - GO TO 750 -723 MSG = 'DASPK-- EPLI (=R1) ILLEGAL. EITHER .LE. 0.D0 OR .GE. 1.D0' - CALL XERRWD(MSG,58,23,0,0,0,0,1,RWORK(LEPLI),0.0D0) - GO TO 750 -724 MSG = 'DASPK-- ILLEGAL IWORK VALUE FOR INFO(11) .NE. 0' - CALL XERRWD(MSG,48,24,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -725 MSG = 'DASPK-- ONE OF THE INPUTS FOR INFO(17) = 1 IS ILLEGAL' - CALL XERRWD(MSG,54,25,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -726 MSG = 'DASPK-- ILLEGAL IWORK VALUE FOR INFO(10) .NE. 0' - CALL XERRWD(MSG,48,26,0,0,0,0,0,0.0D0,0.0D0) - GO TO 750 -727 MSG = 'DASPK-- Y(I) AND IWORK(40+I) (I=I1) INCONSISTENT' - CALL XERRWD(MSG,49,27,0,1,IRET,0,0,0.0D0,0.0D0) - GO TO 750 -750 IF(INFO(1).EQ.-1) GO TO 760 - INFO(1)=-1 - IDID=-33 - RETURN -760 MSG = 'DASPK-- REPEATED OCCURRENCES OF ILLEGAL INPUT' - CALL XERRWD(MSG,46,701,0,0,0,0,0,0.0D0,0.0D0) -770 MSG = 'DASPK-- RUN TERMINATED. APPARENT INFINITE LOOP' - CALL XERRWD(MSG,47,702,1,0,0,0,0,0.0D0,0.0D0) - RETURN -C -C------END OF SUBROUTINE DDASPK----------------------------------------- - END - SUBROUTINE DDASIC (X, Y, YPRIME, NEQ, ICOPT, ID, RES, JAC, PSOL, - * H, TSCALE, WT, NIC, IDID, RPAR, IPAR, PHI, SAVR, DELTA, E, - * YIC, YPIC, PWK, WM, IWM, UROUND, EPLI, SQRTN, RSQRTN, - * EPCONI, STPTOL, JFLG, ICNFLG, ICNSTR, NLSIC) -C -C***BEGIN PROLOGUE DDASIC -C***REFER TO DDASPK -C***DATE WRITTEN 940628 (YYMMDD) -C***REVISION DATE 941206 (YYMMDD) -C***REVISION DATE 950714 (YYMMDD) -C***REVISION DATE 000628 TSCALE argument added. -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DDASIC is a driver routine to compute consistent initial values -C for Y and YPRIME. There are two different options: -C Denoting the differential variables in Y by Y_d, and -C the algebraic variables by Y_a, the problem solved is either: -C 1. Given Y_d, calculate Y_a and Y_d', or -C 2. Given Y', calculate Y. -C In either case, initial values for the given components -C are input, and initial guesses for the unknown components -C must also be provided as input. -C -C The external routine NLSIC solves the resulting nonlinear system. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector at X. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of equations to be integrated. -C ICOPT -- Flag indicating initial condition option chosen. -C ICOPT = 1 for option 1 above. -C ICOPT = 2 for option 2. -C ID -- Array of dimension NEQ, which must be initialized -C if option 1 is chosen. -C ID(i) = +1 if Y_i is a differential variable, -C ID(i) = -1 if Y_i is an algebraic variable. -C RES -- External user-supplied subroutine to evaluate the -C residual. See RES description in DDASPK prologue. -C JAC -- External user-supplied routine to update Jacobian -C or preconditioner information in the nonlinear solver -C (optional). See JAC description in DDASPK prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C See PSOL in DDASPK prologue. -C H -- Scaling factor in iteration matrix. DDASIC may -C reduce H to achieve convergence. -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C WT -- Vector of weights for error criterion. -C NIC -- Input number of initial condition calculation call -C (= 1 or 2). -C IDID -- Completion code. See IDID in DDASPK prologue. -C RPAR,IPAR -- Real and integer parameter arrays that -C are used for communication between the -C calling program and external user routines. -C They are not altered by DNSK -C PHI -- Work space for DDASIC of length at least 2*NEQ. -C SAVR -- Work vector for DDASIC of length NEQ. -C DELTA -- Work vector for DDASIC of length NEQ. -C E -- Work vector for DDASIC of length NEQ. -C YIC,YPIC -- Work vectors for DDASIC, each of length NEQ. -C PWK -- Work vector for DDASIC of length NEQ. -C WM,IWM -- Real and integer arrays storing -C information required by the linear solver. -C EPCONI -- Test constant for Newton iteration convergence. -C ICNFLG -- Flag showing whether constraints on Y are to apply. -C ICNSTR -- Integer array of length NEQ with constraint types. -C -C The other parameters are for use internally by DDASIC. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DCOPY, NLSIC -C -C***END PROLOGUE DDASIC -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),ID(*),WT(*),PHI(NEQ,*) - DIMENSION SAVR(*),DELTA(*),E(*),YIC(*),YPIC(*),PWK(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*), ICNSTR(*) - EXTERNAL RES, JAC, PSOL, NLSIC -C - PARAMETER (LCFN=15) - PARAMETER (LMXNH=34) -C -C The following parameters are data-loaded here: -C RHCUT = factor by which H is reduced on retry of Newton solve. -C RATEMX = maximum convergence rate for which Newton iteration -C is considered converging. -C - SAVE RHCUT, RATEMX - DATA RHCUT/0.1D0/, RATEMX/0.8D0/ -C -C -C----------------------------------------------------------------------- -C BLOCK 1. -C Initializations. -C JSKIP is a flag set to 1 when NIC = 2 and NH = 1, to signal that -C the initial call to the JAC routine is to be skipped then. -C Save Y and YPRIME in PHI. Initialize IDID, NH, and CJ. -C----------------------------------------------------------------------- -C - MXNH = IWM(LMXNH) - IDID = 1 - NH = 1 - JSKIP = 0 - IF (NIC .EQ. 2) JSKIP = 1 - CALL DCOPY (NEQ, Y, 1, PHI(1,1), 1) - CALL DCOPY (NEQ, YPRIME, 1, PHI(1,2), 1) -C - IF (ICOPT .EQ. 2) THEN - CJ = 0.0D0 - ELSE - CJ = 1.0D0/H - ENDIF -C -C----------------------------------------------------------------------- -C BLOCK 2 -C Call the nonlinear system solver to obtain -C consistent initial values for Y and YPRIME. -C----------------------------------------------------------------------- -C - 200 CONTINUE - CALL NLSIC(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JAC,PSOL,H,TSCALE,WT, - * JSKIP,RPAR,IPAR,SAVR,DELTA,E,YIC,YPIC,PWK,WM,IWM,CJ,UROUND, - * EPLI,SQRTN,RSQRTN,EPCONI,RATEMX,STPTOL,JFLG,ICNFLG,ICNSTR, - * IERNLS) -C - IF (IERNLS .EQ. 0) RETURN -C -C----------------------------------------------------------------------- -C BLOCK 3 -C The nonlinear solver was unsuccessful. Increment NCFN. -C Return with IDID = -12 if either -C IERNLS = -1: error is considered unrecoverable, -C ICOPT = 2: we are doing initialization problem type 2, or -C NH = MXNH: the maximum number of H values has been tried. -C Otherwise (problem 1 with IERNLS .GE. 1), reduce H and try again. -C If IERNLS > 1, restore Y and YPRIME to their original values. -C----------------------------------------------------------------------- -C - IWM(LCFN) = IWM(LCFN) + 1 - JSKIP = 0 -C - IF (IERNLS .EQ. -1) GO TO 350 - IF (ICOPT .EQ. 2) GO TO 350 - IF (NH .EQ. MXNH) GO TO 350 -C - NH = NH + 1 - H = H*RHCUT - CJ = 1.0D0/H -C - IF (IERNLS .EQ. 1) GO TO 200 -C - CALL DCOPY (NEQ, PHI(1,1), 1, Y, 1) - CALL DCOPY (NEQ, PHI(1,2), 1, YPRIME, 1) - GO TO 200 -C - 350 IDID = -12 - RETURN -C -C------END OF SUBROUTINE DDASIC----------------------------------------- - END - SUBROUTINE DYYPNW (NEQ, Y, YPRIME, CJ, RL, P, ICOPT, ID, - * YNEW, YPNEW) -C -C***BEGIN PROLOGUE DYYPNW -C***REFER TO DLINSK -C***DATE WRITTEN 940830 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DYYPNW calculates the new (Y,YPRIME) pair needed in the -C linesearch algorithm based on the current lambda value. It is -C called by DLINSK and DLINSD. Based on the ICOPT and ID values, -C the corresponding entry in Y or YPRIME is updated. -C -C In addition to the parameters described in the calling programs, -C the parameters represent -C -C P -- Array of length NEQ that contains the current -C approximate Newton step. -C RL -- Scalar containing the current lambda value. -C YNEW -- Array of length NEQ containing the updated Y vector. -C YPNEW -- Array of length NEQ containing the updated YPRIME -C vector. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED (NONE) -C -C***END PROLOGUE DYYPNW -C -C - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - DIMENSION Y(*), YPRIME(*), YNEW(*), YPNEW(*), ID(*), P(*) -C - IF (ICOPT .EQ. 1) THEN - DO 10 I=1,NEQ - IF(ID(I) .LT. 0) THEN - YNEW(I) = Y(I) - RL*P(I) - YPNEW(I) = YPRIME(I) - ELSE - YNEW(I) = Y(I) - YPNEW(I) = YPRIME(I) - RL*CJ*P(I) - ENDIF - 10 CONTINUE - ELSE - DO 20 I = 1,NEQ - YNEW(I) = Y(I) - RL*P(I) - YPNEW(I) = YPRIME(I) - 20 CONTINUE - ENDIF - RETURN -C----------------------- END OF SUBROUTINE DYYPNW ---------------------- - END - SUBROUTINE DDSTP(X,Y,YPRIME,NEQ,RES,JAC,PSOL,H,WT,VT, - * JSTART,IDID,RPAR,IPAR,PHI,SAVR,DELTA,E,WM,IWM, - * ALPHA,BETA,GAMMA,PSI,SIGMA,CJ,CJOLD,HOLD,S,HMIN,UROUND, - * EPLI,SQRTN,RSQRTN,EPCON,IPHASE,JCALC,JFLG,K,KOLD,NS,NONNEG, - * NTYPE,NLS) -C -C***BEGIN PROLOGUE DDSTP -C***REFER TO DDASPK -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940909 (YYMMDD) (Reset PSI(1), PHI(*,2) at 690) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DDSTP solves a system of differential/algebraic equations of -C the form G(X,Y,YPRIME) = 0, for one step (normally from X to X+H). -C -C The methods used are modified divided difference, fixed leading -C coefficient forms of backward differentiation formulas. -C The code adjusts the stepsize and order to control the local error -C per step. -C -C -C The parameters represent -C X -- Independent variable. -C Y -- Solution vector at X. -C YPRIME -- Derivative of solution vector -C after successful step. -C NEQ -- Number of equations to be integrated. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C JAC -- External user-supplied routine to update -C Jacobian or preconditioner information in the -C nonlinear solver. See JAC description in DDASPK -C prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C (This is optional). See PSOL in DDASPK prologue. -C H -- Appropriate step size for next step. -C Normally determined by the code. -C WT -- Vector of weights for error criterion used in Newton test. -C VT -- Masked vector of weights used in error test. -C JSTART -- Integer variable set 0 for -C first step, 1 otherwise. -C IDID -- Completion code returned from the nonlinear solver. -C See IDID description in DDASPK prologue. -C RPAR,IPAR -- Real and integer parameter arrays that -C are used for communication between the -C calling program and external user routines. -C They are not altered by DNSK -C PHI -- Array of divided differences used by -C DDSTP. The length is NEQ*(K+1), where -C K is the maximum order. -C SAVR -- Work vector for DDSTP of length NEQ. -C DELTA,E -- Work vectors for DDSTP of length NEQ. -C WM,IWM -- Real and integer arrays storing -C information required by the linear solver. -C -C The other parameters are information -C which is needed internally by DDSTP to -C continue from step to step. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C NLS, DDWNRM, DDATRP -C -C***END PROLOGUE DDSTP -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*),VT(*) - DIMENSION PHI(NEQ,*),SAVR(*),DELTA(*),E(*) - DIMENSION WM(*),IWM(*) - DIMENSION PSI(*),ALPHA(*),BETA(*),GAMMA(*),SIGMA(*) - DIMENSION RPAR(*),IPAR(*) - EXTERNAL RES, JAC, PSOL, NLS -C - PARAMETER (LMXORD=3) - PARAMETER (LNST=11, LETF=14, LCFN=15) -C -C -C----------------------------------------------------------------------- -C BLOCK 1. -C Initialize. On the first call, set -C the order to 1 and initialize -C other variables. -C----------------------------------------------------------------------- -C -C Initializations for all calls -C - XOLD=X - NCF=0 - NEF=0 - IF(JSTART .NE. 0) GO TO 120 -C -C If this is the first step, perform -C other initializations -C - K=1 - KOLD=0 - HOLD=0.0D0 - PSI(1)=H - CJ = 1.D0/H - IPHASE = 0 - NS=0 -120 CONTINUE -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 2 -C Compute coefficients of formulas for -C this step. -C----------------------------------------------------------------------- -200 CONTINUE - KP1=K+1 - KP2=K+2 - KM1=K-1 - IF(H.NE.HOLD.OR.K .NE. KOLD) NS = 0 - NS=MIN0(NS+1,KOLD+2) - NSP1=NS+1 - IF(KP1 .LT. NS)GO TO 230 -C - BETA(1)=1.0D0 - ALPHA(1)=1.0D0 - TEMP1=H - GAMMA(1)=0.0D0 - SIGMA(1)=1.0D0 - DO 210 I=2,KP1 - TEMP2=PSI(I-1) - PSI(I-1)=TEMP1 - BETA(I)=BETA(I-1)*PSI(I-1)/TEMP2 - TEMP1=TEMP2+H - ALPHA(I)=H/TEMP1 - SIGMA(I)=(I-1)*SIGMA(I-1)*ALPHA(I) - GAMMA(I)=GAMMA(I-1)+ALPHA(I-1)/H -210 CONTINUE - PSI(KP1)=TEMP1 -230 CONTINUE -C -C Compute ALPHAS, ALPHA0 -C - ALPHAS = 0.0D0 - ALPHA0 = 0.0D0 - DO 240 I = 1,K - ALPHAS = ALPHAS - 1.0D0/I - ALPHA0 = ALPHA0 - ALPHA(I) -240 CONTINUE -C -C Compute leading coefficient CJ -C - CJLAST = CJ - CJ = -ALPHAS/H -C -C Compute variable stepsize error coefficient CK -C - CK = ABS(ALPHA(KP1) + ALPHAS - ALPHA0) - CK = MAX(CK,ALPHA(KP1)) -C -C Change PHI to PHI STAR -C - IF(KP1 .LT. NSP1) GO TO 280 - DO 270 J=NSP1,KP1 - DO 260 I=1,NEQ -260 PHI(I,J)=BETA(J)*PHI(I,J) -270 CONTINUE -280 CONTINUE -C -C Update time -C - X=X+H -C -C Initialize IDID to 1 -C - IDID = 1 -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 3 -C Call the nonlinear system solver to obtain the solution and -C derivative. -C----------------------------------------------------------------------- -C - CALL NLS(X,Y,YPRIME,NEQ, - * RES,JAC,PSOL,H,WT,JSTART,IDID,RPAR,IPAR,PHI,GAMMA, - * SAVR,DELTA,E,WM,IWM,CJ,CJOLD,CJLAST,S, - * UROUND,EPLI,SQRTN,RSQRTN,EPCON,JCALC,JFLG,KP1, - * NONNEG,NTYPE,IERNLS) -C - IF(IERNLS .NE. 0)GO TO 600 -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 4 -C Estimate the errors at orders K,K-1,K-2 -C as if constant stepsize was used. Estimate -C the local error at order K and test -C whether the current step is successful. -C----------------------------------------------------------------------- -C -C Estimate errors at orders K,K-1,K-2 -C - ENORM = DDWNRM(NEQ,E,VT,RPAR,IPAR) - ERK = SIGMA(K+1)*ENORM - TERK = (K+1)*ERK - EST = ERK - KNEW=K - IF(K .EQ. 1)GO TO 430 - DO 405 I = 1,NEQ -405 DELTA(I) = PHI(I,KP1) + E(I) - ERKM1=SIGMA(K)*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) - TERKM1 = K*ERKM1 - IF(K .GT. 2)GO TO 410 - IF(TERKM1 .LE. 0.5*TERK)GO TO 420 - GO TO 430 -410 CONTINUE - DO 415 I = 1,NEQ -415 DELTA(I) = PHI(I,K) + DELTA(I) - ERKM2=SIGMA(K-1)*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) - TERKM2 = (K-1)*ERKM2 - IF(MAX(TERKM1,TERKM2).GT.TERK)GO TO 430 -C -C Lower the order -C -420 CONTINUE - KNEW=K-1 - EST = ERKM1 -C -C -C Calculate the local error for the current step -C to see if the step was successful -C -430 CONTINUE - ERR = CK * ENORM - IF(ERR .GT. 1.0D0)GO TO 600 -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 5 -C The step is successful. Determine -C the best order and stepsize for -C the next step. Update the differences -C for the next step. -C----------------------------------------------------------------------- - IDID=1 - IWM(LNST)=IWM(LNST)+1 - KDIFF=K-KOLD - KOLD=K - HOLD=H -C -C -C Estimate the error at order K+1 unless -C already decided to lower order, or -C already using maximum order, or -C stepsize not constant, or -C order raised in previous step -C - IF(KNEW.EQ.KM1.OR.K.EQ.IWM(LMXORD))IPHASE=1 - IF(IPHASE .EQ. 0)GO TO 545 - IF(KNEW.EQ.KM1)GO TO 540 - IF(K.EQ.IWM(LMXORD)) GO TO 550 - IF(KP1.GE.NS.OR.KDIFF.EQ.1)GO TO 550 - DO 510 I=1,NEQ -510 DELTA(I)=E(I)-PHI(I,KP2) - ERKP1 = (1.0D0/(K+2))*DDWNRM(NEQ,DELTA,VT,RPAR,IPAR) - TERKP1 = (K+2)*ERKP1 - IF(K.GT.1)GO TO 520 - IF(TERKP1.GE.0.5D0*TERK)GO TO 550 - GO TO 530 -520 IF(TERKM1.LE.MIN(TERK,TERKP1))GO TO 540 - IF(TERKP1.GE.TERK.OR.K.EQ.IWM(LMXORD))GO TO 550 -C -C Raise order -C -530 K=KP1 - EST = ERKP1 - GO TO 550 -C -C Lower order -C -540 K=KM1 - EST = ERKM1 - GO TO 550 -C -C If IPHASE = 0, increase order by one and multiply stepsize by -C factor two -C -545 K = KP1 - HNEW = H*2.0D0 - H = HNEW - GO TO 575 -C -C -C Determine the appropriate stepsize for -C the next step. -C -550 HNEW=H - TEMP2=K+1 - R=(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) - IF(R .LT. 2.0D0) GO TO 555 - HNEW = 2.0D0*H - GO TO 560 -555 IF(R .GT. 1.0D0) GO TO 560 - R = MAX(0.5D0,MIN(0.9D0,R)) - HNEW = H*R -560 H=HNEW -C -C -C Update differences for next step -C -575 CONTINUE - IF(KOLD.EQ.IWM(LMXORD))GO TO 585 - DO 580 I=1,NEQ -580 PHI(I,KP2)=E(I) -585 CONTINUE - DO 590 I=1,NEQ -590 PHI(I,KP1)=PHI(I,KP1)+E(I) - DO 595 J1=2,KP1 - J=KP1-J1+1 - DO 595 I=1,NEQ -595 PHI(I,J)=PHI(I,J)+PHI(I,J+1) - JSTART = 1 - RETURN -C -C -C -C -C -C----------------------------------------------------------------------- -C BLOCK 6 -C The step is unsuccessful. Restore X,PSI,PHI -C Determine appropriate stepsize for -C continuing the integration, or exit with -C an error flag if there have been many -C failures. -C----------------------------------------------------------------------- -600 IPHASE = 1 -C -C Restore X,PHI,PSI -C - X=XOLD - IF(KP1.LT.NSP1)GO TO 630 - DO 620 J=NSP1,KP1 - TEMP1=1.0D0/BETA(J) - DO 610 I=1,NEQ -610 PHI(I,J)=TEMP1*PHI(I,J) -620 CONTINUE -630 CONTINUE - DO 640 I=2,KP1 -640 PSI(I-1)=PSI(I)-H -C -C -C Test whether failure is due to nonlinear solver -C or error test -C - IF(IERNLS .EQ. 0)GO TO 660 - IWM(LCFN)=IWM(LCFN)+1 -C -C -C The nonlinear solver failed to converge. -C Determine the cause of the failure and take appropriate action. -C If IERNLS .LT. 0, then return. Otherwise, reduce the stepsize -C and try again, unless too many failures have occurred. -C - IF (IERNLS .LT. 0) GO TO 675 - NCF = NCF + 1 - R = 0.25D0 - H = H*R - IF (NCF .LT. 10 .AND. ABS(H) .GE. HMIN) GO TO 690 - IF (IDID .EQ. 1) IDID = -7 - IF (NEF .GE. 3) IDID = -9 - GO TO 675 -C -C -C The nonlinear solver converged, and the cause -C of the failure was the error estimate -C exceeding the tolerance. -C -660 NEF=NEF+1 - IWM(LETF)=IWM(LETF)+1 - IF (NEF .GT. 1) GO TO 665 -C -C On first error test failure, keep current order or lower -C order by one. Compute new stepsize based on differences -C of the solution. -C - K = KNEW - TEMP2 = K + 1 - R = 0.90D0*(2.0D0*EST+0.0001D0)**(-1.0D0/TEMP2) - R = MAX(0.25D0,MIN(0.9D0,R)) - H = H*R - IF (ABS(H) .GE. HMIN) GO TO 690 - IDID = -6 - GO TO 675 -C -C On second error test failure, use the current order or -C decrease order by one. Reduce the stepsize by a factor of -C one quarter. -C -665 IF (NEF .GT. 2) GO TO 670 - K = KNEW - R = 0.25D0 - H = R*H - IF (ABS(H) .GE. HMIN) GO TO 690 - IDID = -6 - GO TO 675 -C -C On third and subsequent error test failures, set the order to -C one, and reduce the stepsize by a factor of one quarter. -C -670 K = 1 - R = 0.25D0 - H = R*H - IF (ABS(H) .GE. HMIN) GO TO 690 - IDID = -6 - GO TO 675 -C -C -C -C -C For all crashes, restore Y to its last value, -C interpolate to find YPRIME at last X, and return. -C -C Before returning, verify that the user has not set -C IDID to a nonnegative value. If the user has set IDID -C to a nonnegative value, then reset IDID to be -7, indicating -C a failure in the nonlinear system solver. -C -675 CONTINUE - CALL DDATRP(X,X,Y,YPRIME,NEQ,K,PHI,PSI) - JSTART = 1 - IF (IDID .GE. 0) IDID = -7 - RETURN -C -C -C Go back and try this step again. -C If this is the first step, reset PSI(1) and rescale PHI(*,2). -C -690 IF (KOLD .EQ. 0) THEN - PSI(1) = H - DO 695 I = 1,NEQ -695 PHI(I,2) = R*PHI(I,2) - ENDIF - GO TO 200 -C -C------END OF SUBROUTINE DDSTP------------------------------------------ - END - SUBROUTINE DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) -C -C***BEGIN PROLOGUE DCNSTR -C***DATE WRITTEN 950808 (YYMMDD) -C***REVISION DATE 950814 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This subroutine checks for constraint violations in the proposed -C new approximate solution YNEW. -C If a constraint violation occurs, then a new step length, TAU, -C is calculated, and this value is to be given to the linesearch routine -C to calculate a new approximate solution YNEW. -C -C On entry: -C -C NEQ -- size of the nonlinear system, and the length of arrays -C Y, YNEW and ICNSTR. -C -C Y -- real array containing the current approximate y. -C -C YNEW -- real array containing the new approximate y. -C -C ICNSTR -- INTEGER array of length NEQ containing flags indicating -C which entries in YNEW are to be constrained. -C if ICNSTR(I) = 2, then YNEW(I) must be .GT. 0, -C if ICNSTR(I) = 1, then YNEW(I) must be .GE. 0, -C if ICNSTR(I) = -1, then YNEW(I) must be .LE. 0, while -C if ICNSTR(I) = -2, then YNEW(I) must be .LT. 0, while -C if ICNSTR(I) = 0, then YNEW(I) is not constrained. -C -C RLX -- real scalar restricting update, if ICNSTR(I) = 2 or -2, -C to ABS( (YNEW-Y)/Y ) < FAC2*RLX in component I. -C -C TAU -- the current size of the step length for the linesearch. -C -C On return -C -C TAU -- the adjusted size of the step length if a constraint -C violation occurred (otherwise, it is unchanged). it is -C the step length to give to the linesearch routine. -C -C IRET -- output flag. -C IRET=0 means that YNEW satisfied all constraints. -C IRET=1 means that YNEW failed to satisfy all the -C constraints, and a new linesearch step -C must be computed. -C -C IVAR -- index of variable causing constraint to be violated. -C -C----------------------------------------------------------------------- - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(NEQ), YNEW(NEQ), ICNSTR(NEQ) - SAVE FAC, FAC2, ZERO - DATA FAC /0.6D0/, FAC2 /0.9D0/, ZERO/0.0D0/ -C----------------------------------------------------------------------- -C Check constraints for proposed new step YNEW. If a constraint has -C been violated, then calculate a new step length, TAU, to be -C used in the linesearch routine. -C----------------------------------------------------------------------- - IRET = 0 - RDYMX = ZERO - IVAR = 0 - DO 100 I = 1,NEQ -C - IF (ICNSTR(I) .EQ. 2) THEN - RDY = ABS( (YNEW(I)-Y(I))/Y(I) ) - IF (RDY .GT. RDYMX) THEN - RDYMX = RDY - IVAR = I - ENDIF - IF (YNEW(I) .LE. ZERO) THEN - TAU = FAC*TAU - IVAR = I - IRET = 1 - RETURN - ENDIF -C - ELSEIF (ICNSTR(I) .EQ. 1) THEN - IF (YNEW(I) .LT. ZERO) THEN - TAU = FAC*TAU - IVAR = I - IRET = 1 - RETURN - ENDIF -C - ELSEIF (ICNSTR(I) .EQ. -1) THEN - IF (YNEW(I) .GT. ZERO) THEN - TAU = FAC*TAU - IVAR = I - IRET = 1 - RETURN - ENDIF -C - ELSEIF (ICNSTR(I) .EQ. -2) THEN - RDY = ABS( (YNEW(I)-Y(I))/Y(I) ) - IF (RDY .GT. RDYMX) THEN - RDYMX = RDY - IVAR = I - ENDIF - IF (YNEW(I) .GE. ZERO) THEN - TAU = FAC*TAU - IVAR = I - IRET = 1 - RETURN - ENDIF -C - ENDIF - 100 CONTINUE - - IF(RDYMX .GE. RLX) THEN - TAU = FAC2*TAU*RLX/RDYMX - IRET = 1 - ENDIF -C - RETURN -C----------------------- END OF SUBROUTINE DCNSTR ---------------------- - END - SUBROUTINE DCNST0 (NEQ, Y, ICNSTR, IRET) -C -C***BEGIN PROLOGUE DCNST0 -C***DATE WRITTEN 950808 (YYMMDD) -C***REVISION DATE 950808 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This subroutine checks for constraint violations in the initial -C approximate solution u. -C -C On entry -C -C NEQ -- size of the nonlinear system, and the length of arrays -C Y and ICNSTR. -C -C Y -- real array containing the initial approximate root. -C -C ICNSTR -- INTEGER array of length NEQ containing flags indicating -C which entries in Y are to be constrained. -C if ICNSTR(I) = 2, then Y(I) must be .GT. 0, -C if ICNSTR(I) = 1, then Y(I) must be .GE. 0, -C if ICNSTR(I) = -1, then Y(I) must be .LE. 0, while -C if ICNSTR(I) = -2, then Y(I) must be .LT. 0, while -C if ICNSTR(I) = 0, then Y(I) is not constrained. -C -C On return -C -C IRET -- output flag. -C IRET=0 means that u satisfied all constraints. -C IRET.NE.0 means that Y(IRET) failed to satisfy its -C constraint. -C -C----------------------------------------------------------------------- - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(NEQ), ICNSTR(NEQ) - SAVE ZERO - DATA ZERO/0.D0/ -C----------------------------------------------------------------------- -C Check constraints for initial Y. If a constraint has been violated, -C set IRET = I to signal an error return to calling routine. -C----------------------------------------------------------------------- - IRET = 0 - DO 100 I = 1,NEQ - IF (ICNSTR(I) .EQ. 2) THEN - IF (Y(I) .LE. ZERO) THEN - IRET = I - RETURN - ENDIF - ELSEIF (ICNSTR(I) .EQ. 1) THEN - IF (Y(I) .LT. ZERO) THEN - IRET = I - RETURN - ENDIF - ELSEIF (ICNSTR(I) .EQ. -1) THEN - IF (Y(I) .GT. ZERO) THEN - IRET = I - RETURN - ENDIF - ELSEIF (ICNSTR(I) .EQ. -2) THEN - IF (Y(I) .GE. ZERO) THEN - IRET = I - RETURN - ENDIF - ENDIF - 100 CONTINUE - RETURN -C----------------------- END OF SUBROUTINE DCNST0 ---------------------- - END - SUBROUTINE DDAWTS(NEQ,IWT,RTOL,ATOL,Y,WT,RPAR,IPAR) -C -C***BEGIN PROLOGUE DDAWTS -C***REFER TO DDASPK -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***END PROLOGUE DDAWTS -C----------------------------------------------------------------------- -C This subroutine sets the error weight vector, -C WT, according to WT(I)=RTOL(I)*ABS(Y(I))+ATOL(I), -C I = 1 to NEQ. -C RTOL and ATOL are scalars if IWT = 0, -C and vectors if IWT = 1. -C----------------------------------------------------------------------- -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION RTOL(*),ATOL(*),Y(*),WT(*) - DIMENSION RPAR(*),IPAR(*) - RTOLI=RTOL(1) - ATOLI=ATOL(1) - DO 20 I=1,NEQ - IF (IWT .EQ.0) GO TO 10 - RTOLI=RTOL(I) - ATOLI=ATOL(I) -10 WT(I)=RTOLI*ABS(Y(I))+ATOLI -20 CONTINUE - RETURN -C -C------END OF SUBROUTINE DDAWTS----------------------------------------- - END - SUBROUTINE DINVWT(NEQ,WT,IER) -C -C***BEGIN PROLOGUE DINVWT -C***REFER TO DDASPK -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 950125 (YYMMDD) -C***END PROLOGUE DINVWT -C----------------------------------------------------------------------- -C This subroutine checks the error weight vector WT, of length NEQ, -C for components that are .le. 0, and if none are found, it -C inverts the WT(I) in place. This replaces division operations -C with multiplications in all norm evaluations. -C IER is returned as 0 if all WT(I) were found positive, -C and the first I with WT(I) .le. 0.0 otherwise. -C----------------------------------------------------------------------- -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION WT(*) -C - DO 10 I = 1,NEQ - IF (WT(I) .LE. 0.0D0) GO TO 30 - 10 CONTINUE - DO 20 I = 1,NEQ - 20 WT(I) = 1.0D0/WT(I) - IER = 0 - RETURN -C - 30 IER = I - RETURN -C -C------END OF SUBROUTINE DINVWT----------------------------------------- - END - SUBROUTINE DDATRP(X,XOUT,YOUT,YPOUT,NEQ,KOLD,PHI,PSI) -C -C***BEGIN PROLOGUE DDATRP -C***REFER TO DDASPK -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***END PROLOGUE DDATRP -C -C----------------------------------------------------------------------- -C The methods in subroutine DDSTP use polynomials -C to approximate the solution. DDATRP approximates the -C solution and its derivative at time XOUT by evaluating -C one of these polynomials, and its derivative, there. -C Information defining this polynomial is passed from -C DDSTP, so DDATRP cannot be used alone. -C -C The parameters are -C -C X The current time in the integration. -C XOUT The time at which the solution is desired. -C YOUT The interpolated approximation to Y at XOUT. -C (This is output.) -C YPOUT The interpolated approximation to YPRIME at XOUT. -C (This is output.) -C NEQ Number of equations. -C KOLD Order used on last successful step. -C PHI Array of scaled divided differences of Y. -C PSI Array of past stepsize history. -C----------------------------------------------------------------------- -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION YOUT(*),YPOUT(*) - DIMENSION PHI(NEQ,*),PSI(*) - KOLDP1=KOLD+1 - TEMP1=XOUT-X - DO 10 I=1,NEQ - YOUT(I)=PHI(I,1) -10 YPOUT(I)=0.0D0 - C=1.0D0 - D=0.0D0 - GAMMA=TEMP1/PSI(1) - DO 30 J=2,KOLDP1 - D=D*GAMMA+C/PSI(J-1) - C=C*GAMMA - GAMMA=(TEMP1+PSI(J-1))/PSI(J) - DO 20 I=1,NEQ - YOUT(I)=YOUT(I)+C*PHI(I,J) -20 YPOUT(I)=YPOUT(I)+D*PHI(I,J) -30 CONTINUE - RETURN -C -C------END OF SUBROUTINE DDATRP----------------------------------------- - END - DOUBLE PRECISION FUNCTION DDWNRM(NEQ,V,RWT,RPAR,IPAR) -C -C***BEGIN PROLOGUE DDWNRM -C***ROUTINES CALLED (NONE) -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***END PROLOGUE DDWNRM -C----------------------------------------------------------------------- -C This function routine computes the weighted -C root-mean-square norm of the vector of length -C NEQ contained in the array V, with reciprocal weights -C contained in the array RWT of length NEQ. -C DDWNRM=SQRT((1/NEQ)*SUM(V(I)*RWT(I))**2) -C----------------------------------------------------------------------- -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION V(*),RWT(*) - DIMENSION RPAR(*),IPAR(*) - DDWNRM = 0.0D0 - VMAX = 0.0D0 - DO 10 I = 1,NEQ - IF(ABS(V(I)*RWT(I)) .GT. VMAX) VMAX = ABS(V(I)*RWT(I)) -10 CONTINUE - IF(VMAX .LE. 0.0D0) GO TO 30 - SUM = 0.0D0 - DO 20 I = 1,NEQ -20 SUM = SUM + ((V(I)*RWT(I))/VMAX)**2 - DDWNRM = VMAX*SQRT(SUM/NEQ) -30 CONTINUE - RETURN -C -C------END OF FUNCTION DDWNRM------------------------------------------- - END - SUBROUTINE DDASID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JACD,PDUM,H,TSCALE, - * WT,JSDUM,RPAR,IPAR,DUMSVR,DELTA,R,YIC,YPIC,DUMPWK,WM,IWM,CJ, - * UROUND,DUME,DUMS,DUMR,EPCON,RATEMX,STPTOL,JFDUM, - * ICNFLG,ICNSTR,IERNLS) -C -C***BEGIN PROLOGUE DDASID -C***REFER TO DDASPK -C***DATE WRITTEN 940701 (YYMMDD) -C***REVISION DATE 950808 (YYMMDD) -C***REVISION DATE 951110 Removed unreachable block 390. -C***REVISION DATE 000628 TSCALE argument added. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C -C DDASID solves a nonlinear system of algebraic equations of the -C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in -C the initial conditions. -C -C The method used is a modified Newton scheme. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C ICOPT -- Initial condition option chosen (1 or 2). -C ID -- Array of dimension NEQ, which must be initialized -C if ICOPT = 1. See DDASIC. -C RES -- External user-supplied subroutine to evaluate the -C residual. See RES description in DDASPK prologue. -C JACD -- External user-supplied routine to evaluate the -C Jacobian. See JAC description for the case -C INFO(12) = 0 in the DDASPK prologue. -C PDUM -- Dummy argument. -C H -- Scaling factor for this initial condition calc. -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C WT -- Vector of weights for error criterion. -C JSDUM -- Dummy argument. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C DUMSVR -- Dummy argument. -C DELTA -- Work vector for NLS of length NEQ. -C R -- Work vector for NLS of length NEQ. -C YIC,YPIC -- Work vectors for NLS, each of length NEQ. -C DUMPWK -- Dummy argument. -C WM,IWM -- Real and integer arrays storing matrix information -C such as the matrix of partial derivatives, -C permutation vector, and various other information. -C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). -C UROUND -- Unit roundoff. -C DUME -- Dummy argument. -C DUMS -- Dummy argument. -C DUMR -- Dummy argument. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C RATEMX -- Maximum convergence rate for which Newton iteration -C is considered converging. -C JFDUM -- Dummy argument. -C STPTOL -- Tolerance used in calculating the minimum lambda -C value allowed. -C ICNFLG -- Integer scalar. If nonzero, then constraint -C violations in the proposed new approximate solution -C will be checked for, and the maximum step length -C will be adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C IERNLS -- Error flag for nonlinear solver. -C 0 ==> nonlinear solver converged. -C 1,2 ==> recoverable error inside nonlinear solver. -C 1 => retry with current Y, YPRIME -C 2 => retry with original Y, YPRIME -C -1 ==> unrecoverable error in nonlinear solver. -C -C All variables with "DUM" in their names are dummy variables -C which are not used in this routine. -C -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C RES, DMATD, DNSID -C -C***END PROLOGUE DDASID -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),ID(*),WT(*),ICNSTR(*) - DIMENSION DELTA(*),R(*),YIC(*),YPIC(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - EXTERNAL RES, JACD -C - PARAMETER (LNRE=12, LNJE=13, LMXNIT=32, LMXNJ=33) -C -C -C Perform initializations. -C - MXNIT = IWM(LMXNIT) - MXNJ = IWM(LMXNJ) - IERNLS = 0 - NJ = 0 -C -C Call RES to initialize DELTA. -C - IRES = 0 - IWM(LNRE) = IWM(LNRE) + 1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 370 -C -C Looping point for updating the Jacobian. -C -300 CONTINUE -C -C Initialize all error flags to zero. -C - IERJ = 0 - IRES = 0 - IERNEW = 0 -C -C Reevaluate the iteration matrix, J = dG/dY + CJ*dG/dYPRIME, -C where G(X,Y,YPRIME) = 0. -C - NJ = NJ + 1 - IWM(LNJE)=IWM(LNJE)+1 - CALL DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IERJ,WT,R, - * WM,IWM,RES,IRES,UROUND,JACD,RPAR,IPAR) - IF (IRES .LT. 0 .OR. IERJ .NE. 0) GO TO 370 -C -C Call the nonlinear Newton solver for up to MXNIT iterations. -C - CALL DNSID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,WT,RPAR,IPAR,DELTA,R, - * YIC,YPIC,WM,IWM,CJ,TSCALE,EPCON,RATEMX,MXNIT,STPTOL, - * ICNFLG,ICNSTR,IERNEW) -C - IF (IERNEW .EQ. 1 .AND. NJ .LT. MXNJ) THEN -C -C MXNIT iterations were done, the convergence rate is < 1, -C and the number of Jacobian evaluations is less than MXNJ. -C Call RES, reevaluate the Jacobian, and try again. -C - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 370 - GO TO 300 - ENDIF -C - IF (IERNEW .NE. 0) GO TO 380 - - RETURN -C -C -C Unsuccessful exits from nonlinear solver. -C Compute IERNLS accordingly. -C -370 IERNLS = 2 - IF (IRES .LE. -2) IERNLS = -1 - RETURN -C -380 IERNLS = MIN(IERNEW,2) - RETURN -C -C------END OF SUBROUTINE DDASID----------------------------------------- - END - SUBROUTINE DNSID(X,Y,YPRIME,NEQ,ICOPT,ID,RES,WT,RPAR,IPAR, - * DELTA,R,YIC,YPIC,WM,IWM,CJ,TSCALE,EPCON,RATEMX,MAXIT,STPTOL, - * ICNFLG,ICNSTR,IERNEW) -C -C***BEGIN PROLOGUE DNSID -C***REFER TO DDASPK -C***DATE WRITTEN 940701 (YYMMDD) -C***REVISION DATE 950713 (YYMMDD) -C***REVISION DATE 000628 TSCALE argument added. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNSID solves a nonlinear system of algebraic equations of the -C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME -C in the initial conditions. -C -C The method used is a modified Newton scheme. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C ICOPT -- Initial condition option chosen (1 or 2). -C ID -- Array of dimension NEQ, which must be initialized -C if ICOPT = 1. See DDASIC. -C RES -- External user-supplied subroutine to evaluate the -C residual. See RES description in DDASPK prologue. -C WT -- Vector of weights for error criterion. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C DELTA -- Residual vector on entry, and work vector of -C length NEQ for DNSID. -C WM,IWM -- Real and integer arrays storing matrix information -C such as the matrix of partial derivatives, -C permutation vector, and various other information. -C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C R -- Array of length NEQ used as workspace by the -C linesearch routine DLINSD. -C YIC,YPIC -- Work vectors for DLINSD, each of length NEQ. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C RATEMX -- Maximum convergence rate for which Newton iteration -C is considered converging. -C MAXIT -- Maximum allowed number of Newton iterations. -C STPTOL -- Tolerance used in calculating the minimum lambda -C value allowed. -C ICNFLG -- Integer scalar. If nonzero, then constraint -C violations in the proposed new approximate solution -C will be checked for, and the maximum step length -C will be adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C IERNEW -- Error flag for Newton iteration. -C 0 ==> Newton iteration converged. -C 1 ==> failed to converge, but RATE .le. RATEMX. -C 2 ==> failed to converge, RATE .gt. RATEMX. -C 3 ==> other recoverable error (IRES = -1, or -C linesearch failed). -C -1 ==> unrecoverable error (IRES = -2). -C -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C DSLVD, DDWNRM, DLINSD, DCOPY -C -C***END PROLOGUE DNSID -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*),R(*) - DIMENSION ID(*),DELTA(*), YIC(*), YPIC(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - DIMENSION ICNSTR(*) - EXTERNAL RES -C - PARAMETER (LNNI=19, LLSOFF=35) -C -C -C Initializations. M is the Newton iteration counter. -C - LSOFF = IWM(LLSOFF) - M = 0 - RATE = 1.0D0 - RLX = 0.4D0 -C -C Compute a new step vector DELTA by back-substitution. -C - CALL DSLVD (NEQ, DELTA, WM, IWM) -C -C Get norm of DELTA. Return now if norm(DELTA) .le. EPCON. -C - DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - FNRM = DELNRM - IF (TSCALE .GT. 0.0D0) FNRM = FNRM*TSCALE*ABS(CJ) - IF (FNRM .LE. EPCON) RETURN -C -C Newton iteration loop. -C - 300 CONTINUE - IWM(LNNI) = IWM(LNNI) + 1 -C -C Call linesearch routine for global strategy and set RATE -C - OLDFNM = FNRM -C - CALL DLINSD (NEQ, Y, X, YPRIME, CJ, TSCALE, DELTA, DELNRM, WT, - * LSOFF, STPTOL, IRET, RES, IRES, WM, IWM, FNRM, ICOPT, - * ID, R, YIC, YPIC, ICNFLG, ICNSTR, RLX, RPAR, IPAR) -C - RATE = FNRM/OLDFNM -C -C Check for error condition from linesearch. - IF (IRET .NE. 0) GO TO 390 -C -C Test for convergence of the iteration, and return or loop. -C - IF (FNRM .LE. EPCON) RETURN -C -C The iteration has not yet converged. Update M. -C Test whether the maximum number of iterations have been tried. -C - M = M + 1 - IF (M .GE. MAXIT) GO TO 380 -C -C Copy the residual to DELTA and its norm to DELNRM, and loop for -C another iteration. -C - CALL DCOPY (NEQ, R, 1, DELTA, 1) - DELNRM = FNRM - GO TO 300 -C -C The maximum number of iterations was done. Set IERNEW and return. -C - 380 IF (RATE .LE. RATEMX) THEN - IERNEW = 1 - ELSE - IERNEW = 2 - ENDIF - RETURN -C - 390 IF (IRES .LE. -2) THEN - IERNEW = -1 - ELSE - IERNEW = 3 - ENDIF - RETURN -C -C -C------END OF SUBROUTINE DNSID------------------------------------------ - END - SUBROUTINE DLINSD (NEQ, Y, T, YPRIME, CJ, TSCALE, P, PNRM, WT, - * LSOFF, STPTOL, IRET, RES, IRES, WM, IWM, - * FNRM, ICOPT, ID, R, YNEW, YPNEW, ICNFLG, - * ICNSTR, RLX, RPAR, IPAR) -C -C***BEGIN PROLOGUE DLINSD -C***REFER TO DNSID -C***DATE WRITTEN 941025 (YYMMDD) -C***REVISION DATE 941215 (YYMMDD) -C***REVISION DATE 960129 Moved line RL = ONE to top block. -C***REVISION DATE 000628 TSCALE argument added. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DLINSD uses a linesearch algorithm to calculate a new (Y,YPRIME) -C pair (YNEW,YPNEW) such that -C -C f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) , -C -C where 0 < RL <= 1. Here, f(y,y') is defined as -C -C f(y,y') = (1/2)*norm( (J-inverse)*G(t,y,y') )**2 , -C -C where norm() is the weighted RMS vector norm, G is the DAE -C system residual function, and J is the system iteration matrix -C (Jacobian). -C -C In addition to the parameters defined elsewhere, we have -C -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C P -- Approximate Newton step used in backtracking. -C PNRM -- Weighted RMS norm of P. -C LSOFF -- Flag showing whether the linesearch algorithm is -C to be invoked. 0 means do the linesearch, and -C 1 means turn off linesearch. -C STPTOL -- Tolerance used in calculating the minimum lambda -C value allowed. -C ICNFLG -- Integer scalar. If nonzero, then constraint violations -C in the proposed new approximate solution will be -C checked for, and the maximum step length will be -C adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C RLX -- Real scalar restricting update size in DCNSTR. -C YNEW -- Array of length NEQ used to hold the new Y in -C performing the linesearch. -C YPNEW -- Array of length NEQ used to hold the new YPRIME in -C performing the linesearch. -C Y -- Array of length NEQ containing the new Y (i.e.,=YNEW). -C YPRIME -- Array of length NEQ containing the new YPRIME -C (i.e.,=YPNEW). -C FNRM -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the -C current (Y,YPRIME) on input and output. -C R -- Work array of length NEQ, containing the scaled -C residual (J-inverse)*G(t,y,y') on return. -C IRET -- Return flag. -C IRET=0 means that a satisfactory (Y,YPRIME) was found. -C IRET=1 means that the routine failed to find a new -C (Y,YPRIME) that was sufficiently distinct from -C the current (Y,YPRIME) pair. -C IRET=2 means IRES .ne. 0 from RES. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C DFNRMD, DYYPNW, DCNSTR, DCOPY, XERRWD -C -C***END PROLOGUE DLINSD -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - EXTERNAL RES - DIMENSION Y(*), YPRIME(*), WT(*), R(*), ID(*) - DIMENSION WM(*), IWM(*) - DIMENSION YNEW(*), YPNEW(*), P(*), ICNSTR(*) - DIMENSION RPAR(*), IPAR(*) - CHARACTER MSG*80 -C - PARAMETER (LNRE=12, LKPRIN=31) -C - SAVE ALPHA, ONE, TWO - DATA ALPHA/1.0D-4/, ONE/1.0D0/, TWO/2.0D0/ -C - KPRIN=IWM(LKPRIN) -C - F1NRM = (FNRM*FNRM)/TWO - RATIO = ONE - IF (KPRIN .GE. 2) THEN - MSG = '------ IN ROUTINE DLINSD-- PNRM = (R1)' - CALL XERRWD(MSG, 38, 901, 0, 0, 0, 0, 1, PNRM, 0.0D0) - ENDIF - TAU = PNRM - RL = ONE -C----------------------------------------------------------------------- -C Check for violations of the constraints, if any are imposed. -C If any violations are found, the step vector P is rescaled, and the -C constraint check is repeated, until no violations are found. -C----------------------------------------------------------------------- - IF (ICNFLG .NE. 0) THEN - 10 CONTINUE - CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) - CALL DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) - IF (IRET .EQ. 1) THEN - RATIO1 = TAU/PNRM - RATIO = RATIO*RATIO1 - DO 20 I = 1,NEQ - 20 P(I) = P(I)*RATIO1 - PNRM = TAU - IF (KPRIN .GE. 2) THEN - MSG = '------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (I1)' - CALL XERRWD(MSG, 50, 902, 0, 1, IVAR, 0, 1, PNRM, 0.0D0) - ENDIF - IF (PNRM .LE. STPTOL) THEN - IRET = 1 - RETURN - ENDIF - GO TO 10 - ENDIF - ENDIF -C - SLPI = (-TWO*F1NRM)*RATIO - RLMIN = STPTOL/PNRM - IF (LSOFF .EQ. 0 .AND. KPRIN .GE. 2) THEN - MSG = '------ MIN. LAMBDA = (R1)' - CALL XERRWD(MSG, 25, 903, 0, 0, 0, 0, 1, RLMIN, 0.0D0) - ENDIF -C----------------------------------------------------------------------- -C Begin iteration to find RL value satisfying alpha-condition. -C If RL becomes less than RLMIN, then terminate with IRET = 1. -C----------------------------------------------------------------------- - 100 CONTINUE - CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) - CALL DFNRMD (NEQ, YNEW, T, YPNEW, R, CJ, TSCALE, WT, RES, IRES, - * FNRMP, WM, IWM, RPAR, IPAR) - IWM(LNRE) = IWM(LNRE) + 1 - IF (IRES .NE. 0) THEN - IRET = 2 - RETURN - ENDIF - IF (LSOFF .EQ. 1) GO TO 150 -C - F1NRMP = FNRMP*FNRMP/TWO - IF (KPRIN .GE. 2) THEN - MSG = '------ LAMBDA = (R1)' - CALL XERRWD(MSG, 20, 904, 0, 0, 0, 0, 1, RL, 0.0D0) - MSG = '------ NORM(F1) = (R1), NORM(F1NEW) = (R2)' - CALL XERRWD(MSG, 43, 905, 0, 0, 0, 0, 2, F1NRM, F1NRMP) - ENDIF - IF (F1NRMP .GT. F1NRM + ALPHA*SLPI*RL) GO TO 200 -C----------------------------------------------------------------------- -C Alpha-condition is satisfied, or linesearch is turned off. -C Copy YNEW,YPNEW to Y,YPRIME and return. -C----------------------------------------------------------------------- - 150 IRET = 0 - CALL DCOPY (NEQ, YNEW, 1, Y, 1) - CALL DCOPY (NEQ, YPNEW, 1, YPRIME, 1) - FNRM = FNRMP - IF (KPRIN .GE. 1) THEN - MSG = '------ LEAVING ROUTINE DLINSD, FNRM = (R1)' - CALL XERRWD(MSG, 42, 906, 0, 0, 0, 0, 1, FNRM, 0.0D0) - ENDIF - RETURN -C----------------------------------------------------------------------- -C Alpha-condition not satisfied. Perform backtrack to compute new RL -C value. If no satisfactory YNEW,YPNEW can be found sufficiently -C distinct from Y,YPRIME, then return IRET = 1. -C----------------------------------------------------------------------- - 200 CONTINUE - IF (RL .LT. RLMIN) THEN - IRET = 1 - RETURN - ENDIF -C - RL = RL/TWO - GO TO 100 -C -C----------------------- END OF SUBROUTINE DLINSD ---------------------- - END - SUBROUTINE DFNRMD (NEQ, Y, T, YPRIME, R, CJ, TSCALE, WT, - * RES, IRES, FNORM, WM, IWM, RPAR, IPAR) -C -C***BEGIN PROLOGUE DFNRMD -C***REFER TO DLINSD -C***DATE WRITTEN 941025 (YYMMDD) -C***REVISION DATE 000628 TSCALE argument added. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DFNRMD calculates the scaled preconditioned norm of the nonlinear -C function used in the nonlinear iteration for obtaining consistent -C initial conditions. Specifically, DFNRMD calculates the weighted -C root-mean-square norm of the vector (J-inverse)*G(T,Y,YPRIME), -C where J is the Jacobian matrix. -C -C In addition to the parameters described in the calling program -C DLINSD, the parameters represent -C -C R -- Array of length NEQ that contains -C (J-inverse)*G(T,Y,YPRIME) on return. -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C FNORM -- Scalar containing the weighted norm of R on return. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C RES, DSLVD, DDWNRM -C -C***END PROLOGUE DFNRMD -C -C - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - EXTERNAL RES - DIMENSION Y(*), YPRIME(*), WT(*), R(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) -C----------------------------------------------------------------------- -C Call RES routine. -C----------------------------------------------------------------------- - IRES = 0 - CALL RES(T,Y,YPRIME,CJ,R,IRES,RPAR,IPAR) - IF (IRES .LT. 0) RETURN -C----------------------------------------------------------------------- -C Apply inverse of Jacobian to vector R. -C----------------------------------------------------------------------- - CALL DSLVD(NEQ,R,WM,IWM) -C----------------------------------------------------------------------- -C Calculate norm of R. -C----------------------------------------------------------------------- - FNORM = DDWNRM(NEQ,R,WT,RPAR,IPAR) - IF (TSCALE .GT. 0.0D0) FNORM = FNORM*TSCALE*ABS(CJ) -C - RETURN -C----------------------- END OF SUBROUTINE DFNRMD ---------------------- - END - SUBROUTINE DNEDD(X,Y,YPRIME,NEQ,RES,JACD,PDUM,H,WT, - * JSTART,IDID,RPAR,IPAR,PHI,GAMMA,DUMSVR,DELTA,E, - * WM,IWM,CJ,CJOLD,CJLAST,S,UROUND,DUME,DUMS,DUMR, - * EPCON,JCALC,JFDUM,KP1,NONNEG,NTYPE,IERNLS) -C -C***BEGIN PROLOGUE DNEDD -C***REFER TO DDASPK -C***DATE WRITTEN 891219 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNEDD solves a nonlinear system of -C algebraic equations of the form -C G(X,Y,YPRIME) = 0 for the unknown Y. -C -C The method used is a modified Newton scheme. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C JACD -- External user-supplied routine to evaluate the -C Jacobian. See JAC description for the case -C INFO(12) = 0 in the DDASPK prologue. -C PDUM -- Dummy argument. -C H -- Appropriate step size for next step. -C WT -- Vector of weights for error criterion. -C JSTART -- Indicates first call to this routine. -C If JSTART = 0, then this is the first call, -C otherwise it is not. -C IDID -- Completion flag, output by DNEDD. -C See IDID description in DDASPK prologue. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C PHI -- Array of divided differences used by -C DNEDD. The length is NEQ*(K+1),where -C K is the maximum order. -C GAMMA -- Array used to predict Y and YPRIME. The length -C is MAXORD+1 where MAXORD is the maximum order. -C DUMSVR -- Dummy argument. -C DELTA -- Work vector for NLS of length NEQ. -C E -- Error accumulation vector for NLS of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information such as the matrix -C of partial derivatives, permutation -C vector, and various other information. -C CJ -- Parameter always proportional to 1/H. -C CJOLD -- Saves the value of CJ as of the last call to DMATD. -C Accounts for changes in CJ needed to -C decide whether to call DMATD. -C CJLAST -- Previous value of CJ. -C S -- A scalar determined by the approximate rate -C of convergence of the Newton iteration and used -C in the convergence test for the Newton iteration. -C -C If RATE is defined to be an estimate of the -C rate of convergence of the Newton iteration, -C then S = RATE/(1.D0-RATE). -C -C The closer RATE is to 0., the faster the Newton -C iteration is converging; the closer RATE is to 1., -C the slower the Newton iteration is converging. -C -C On the first Newton iteration with an up-dated -C preconditioner S = 100.D0, Thus the initial -C RATE of convergence is approximately 1. -C -C S is preserved from call to call so that the rate -C estimate from a previous step can be applied to -C the current step. -C UROUND -- Unit roundoff. -C DUME -- Dummy argument. -C DUMS -- Dummy argument. -C DUMR -- Dummy argument. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C JCALC -- Flag used to determine when to update -C the Jacobian matrix. In general: -C -C JCALC = -1 ==> Call the DMATD routine to update -C the Jacobian matrix. -C JCALC = 0 ==> Jacobian matrix is up-to-date. -C JCALC = 1 ==> Jacobian matrix is out-dated, -C but DMATD will not be called unless -C JCALC is set to -1. -C JFDUM -- Dummy argument. -C KP1 -- The current order(K) + 1; updated across calls. -C NONNEG -- Flag to determine nonnegativity constraints. -C NTYPE -- Identification code for the NLS routine. -C 0 ==> modified Newton; direct solver. -C IERNLS -- Error flag for nonlinear solver. -C 0 ==> nonlinear solver converged. -C 1 ==> recoverable error inside nonlinear solver. -C -1 ==> unrecoverable error inside nonlinear solver. -C -C All variables with "DUM" in their names are dummy variables -C which are not used in this routine. -C -C Following is a list and description of local variables which -C may not have an obvious usage. They are listed in roughly the -C order they occur in this subroutine. -C -C The following group of variables are passed as arguments to -C the Newton iteration solver. They are explained in greater detail -C in DNSD: -C TOLNEW, MULDEL, MAXIT, IERNEW -C -C IERTYP -- Flag which tells whether this subroutine is correct. -C 0 ==> correct subroutine. -C 1 ==> incorrect subroutine. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DDWNRM, RES, DMATD, DNSD -C -C***END PROLOGUE DNEDD -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*) - DIMENSION DELTA(*),E(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - DIMENSION PHI(NEQ,*),GAMMA(*) - EXTERNAL RES, JACD -C - PARAMETER (LNRE=12, LNJE=13) -C - SAVE MULDEL, MAXIT, XRATE - DATA MULDEL/1/, MAXIT/4/, XRATE/0.25D0/ -C -C Verify that this is the correct subroutine. -C - IERTYP = 0 - IF (NTYPE .NE. 0) THEN - IERTYP = 1 - GO TO 380 - ENDIF -C -C If this is the first step, perform initializations. -C - IF (JSTART .EQ. 0) THEN - CJOLD = CJ - JCALC = -1 - ENDIF -C -C Perform all other initializations. -C - IERNLS = 0 -C -C Decide whether new Jacobian is needed. -C - TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) - TEMP2 = 1.0D0/TEMP1 - IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 - IF (CJ .NE. CJLAST) S = 100.D0 -C -C----------------------------------------------------------------------- -C Entry point for updating the Jacobian with current -C stepsize. -C----------------------------------------------------------------------- -300 CONTINUE -C -C Initialize all error flags to zero. -C - IERJ = 0 - IRES = 0 - IERNEW = 0 -C -C Predict the solution and derivative and compute the tolerance -C for the Newton iteration. -C - DO 310 I=1,NEQ - Y(I)=PHI(I,1) -310 YPRIME(I)=0.0D0 - DO 330 J=2,KP1 - DO 320 I=1,NEQ - Y(I)=Y(I)+PHI(I,J) -320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) -330 CONTINUE - PNORM = DDWNRM (NEQ,Y,WT,RPAR,IPAR) - TOLNEW = 100.D0*UROUND*PNORM -C -C Call RES to initialize DELTA. -C - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 -C -C If indicated, reevaluate the iteration matrix -C J = dG/dY + CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). -C Set JCALC to 0 as an indicator that this has been done. -C - IF(JCALC .EQ. -1) THEN - IWM(LNJE)=IWM(LNJE)+1 - JCALC=0 - CALL DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IERJ,WT,E,WM,IWM, - * RES,IRES,UROUND,JACD,RPAR,IPAR) - CJOLD=CJ - S = 100.D0 - IF (IRES .LT. 0) GO TO 380 - IF(IERJ .NE. 0)GO TO 380 - ENDIF -C -C Call the nonlinear Newton solver. -C - TEMP1 = 2.0D0/(1.0D0 + CJ/CJOLD) - CALL DNSD(X,Y,YPRIME,NEQ,RES,PDUM,WT,RPAR,IPAR,DUMSVR, - * DELTA,E,WM,IWM,CJ,DUMS,DUMR,DUME,EPCON,S,TEMP1, - * TOLNEW,MULDEL,MAXIT,IRES,IDUM,IERNEW) -C - IF (IERNEW .GT. 0 .AND. JCALC .NE. 0) THEN -C -C The Newton iteration had a recoverable failure with an old -C iteration matrix. Retry the step with a new iteration matrix. -C - JCALC = -1 - GO TO 300 - ENDIF -C - IF (IERNEW .NE. 0) GO TO 380 -C -C The Newton iteration has converged. If nonnegativity of -C solution is required, set the solution nonnegative, if the -C perturbation to do it is small enough. If the change is too -C large, then consider the corrector iteration to have failed. -C -375 IF(NONNEG .EQ. 0) GO TO 390 - DO 377 I = 1,NEQ -377 DELTA(I) = MIN(Y(I),0.0D0) - DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - IF(DELNRM .GT. EPCON) GO TO 380 - DO 378 I = 1,NEQ -378 E(I) = E(I) - DELTA(I) - GO TO 390 -C -C -C Exits from nonlinear solver. -C No convergence with current iteration -C matrix, or singular iteration matrix. -C Compute IERNLS and IDID accordingly. -C -380 CONTINUE - IF (IRES .LE. -2 .OR. IERTYP .NE. 0) THEN - IERNLS = -1 - IF (IRES .LE. -2) IDID = -11 - IF (IERTYP .NE. 0) IDID = -15 - ELSE - IERNLS = 1 - IF (IRES .LT. 0) IDID = -10 - IF (IERJ .NE. 0) IDID = -8 - ENDIF -C -390 JCALC = 1 - RETURN -C -C------END OF SUBROUTINE DNEDD------------------------------------------ - END - SUBROUTINE DNSD(X,Y,YPRIME,NEQ,RES,PDUM,WT,RPAR,IPAR, - * DUMSVR,DELTA,E,WM,IWM,CJ,DUMS,DUMR,DUME,EPCON, - * S,CONFAC,TOLNEW,MULDEL,MAXIT,IRES,IDUM,IERNEW) -C -C***BEGIN PROLOGUE DNSD -C***REFER TO DDASPK -C***DATE WRITTEN 891219 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 950126 (YYMMDD) -C***REVISION DATE 000711 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNSD solves a nonlinear system of -C algebraic equations of the form -C G(X,Y,YPRIME) = 0 for the unknown Y. -C -C The method used is a modified Newton scheme. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C PDUM -- Dummy argument. -C WT -- Vector of weights for error criterion. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C DUMSVR -- Dummy argument. -C DELTA -- Work vector for DNSD of length NEQ. -C E -- Error accumulation vector for DNSD of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information such as the matrix -C of partial derivatives, permutation -C vector, and various other information. -C CJ -- Parameter always proportional to 1/H (step size). -C DUMS -- Dummy argument. -C DUMR -- Dummy argument. -C DUME -- Dummy argument. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C S -- Used for error convergence tests. -C In the Newton iteration: S = RATE/(1 - RATE), -C where RATE is the estimated rate of convergence -C of the Newton iteration. -C The calling routine passes the initial value -C of S to the Newton iteration. -C CONFAC -- A residual scale factor to improve convergence. -C TOLNEW -- Tolerance on the norm of Newton correction in -C alternative Newton convergence test. -C MULDEL -- A flag indicating whether or not to multiply -C DELTA by CONFAC. -C 0 ==> do not scale DELTA by CONFAC. -C 1 ==> scale DELTA by CONFAC. -C MAXIT -- Maximum allowed number of Newton iterations. -C IRES -- Error flag returned from RES. See RES description -C in DDASPK prologue. If IRES = -1, then IERNEW -C will be set to 1. -C If IRES < -1, then IERNEW will be set to -1. -C IDUM -- Dummy argument. -C IERNEW -- Error flag for Newton iteration. -C 0 ==> Newton iteration converged. -C 1 ==> recoverable error inside Newton iteration. -C -1 ==> unrecoverable error inside Newton iteration. -C -C All arguments with "DUM" in their names are dummy arguments -C which are not used in this routine. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C DSLVD, DDWNRM, RES -C -C***END PROLOGUE DNSD -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*),DELTA(*),E(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - EXTERNAL RES -C - PARAMETER (LNRE=12, LNNI=19) -C -C Initialize Newton counter M and accumulation vector E. -C - M = 0 - DO 100 I=1,NEQ -100 E(I)=0.0D0 -C -C Corrector loop. -C -300 CONTINUE - IWM(LNNI) = IWM(LNNI) + 1 -C -C If necessary, multiply residual by convergence factor. -C - IF (MULDEL .EQ. 1) THEN - DO 320 I = 1,NEQ -320 DELTA(I) = DELTA(I) * CONFAC - ENDIF -C -C Compute a new iterate (back-substitution). -C Store the correction in DELTA. -C - CALL DSLVD(NEQ,DELTA,WM,IWM) -C -C Update Y, E, and YPRIME. -C - DO 340 I=1,NEQ - Y(I)=Y(I)-DELTA(I) - E(I)=E(I)-DELTA(I) -340 YPRIME(I)=YPRIME(I)-CJ*DELTA(I) -C -C Test for convergence of the iteration. -C - DELNRM=DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (M .EQ. 0) THEN - OLDNRM = DELNRM - IF (DELNRM .LE. TOLNEW) GO TO 370 - ELSE - RATE = (DELNRM/OLDNRM)**(1.0D0/M) - IF (RATE .GT. 0.9D0) GO TO 380 - S = RATE/(1.0D0 - RATE) - ENDIF - IF (S*DELNRM .LE. EPCON) GO TO 370 -C -C The corrector has not yet converged. -C Update M and test whether the -C maximum number of iterations have -C been tried. -C - M=M+1 - IF(M.GE.MAXIT) GO TO 380 -C -C Evaluate the residual, -C and go back to do another iteration. -C - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 - GO TO 300 -C -C The iteration has converged. -C -370 RETURN -C -C The iteration has not converged. Set IERNEW appropriately. -C -380 CONTINUE - IF (IRES .LE. -2 ) THEN - IERNEW = -1 - ELSE - IERNEW = 1 - ENDIF - RETURN -C -C -C------END OF SUBROUTINE DNSD------------------------------------------- - END - SUBROUTINE DMATD(NEQ,X,Y,YPRIME,DELTA,CJ,H,IER,EWT,E, - * WM,IWM,RES,IRES,UROUND,JACD,RPAR,IPAR) -C -C***BEGIN PROLOGUE DMATD -C***REFER TO DDASPK -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940701 (YYMMDD) (new LIPVT) -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine computes the iteration matrix -C J = dG/dY+CJ*dG/dYPRIME (where G(X,Y,YPRIME)=0). -C Here J is computed by: -C the user-supplied routine JACD if IWM(MTYPE) is 1 or 4, or -C by numerical difference quotients if IWM(MTYPE) is 2 or 5. -C -C The parameters have the following meanings. -C X = Independent variable. -C Y = Array containing predicted values. -C YPRIME = Array containing predicted derivatives. -C DELTA = Residual evaluated at (X,Y,YPRIME). -C (Used only if IWM(MTYPE)=2 or 5). -C CJ = Scalar parameter defining iteration matrix. -C H = Current stepsize in integration. -C IER = Variable which is .NE. 0 if iteration matrix -C is singular, and 0 otherwise. -C EWT = Vector of error weights for computing norms. -C E = Work space (temporary) of length NEQ. -C WM = Real work space for matrices. On output -C it contains the LU decomposition -C of the iteration matrix. -C IWM = Integer work space containing -C matrix information. -C RES = External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C IRES = Flag which is equal to zero if no illegal values -C in RES, and less than zero otherwise. (If IRES -C is less than zero, the matrix was not completed). -C In this case (if IRES .LT. 0), then IER = 0. -C UROUND = The unit roundoff error of the machine being used. -C JACD = Name of the external user-supplied routine -C to evaluate the iteration matrix. (This routine -C is only used if IWM(MTYPE) is 1 or 4) -C See JAC description for the case INFO(12) = 0 -C in DDASPK prologue. -C RPAR,IPAR= Real and integer parameter arrays that -C are used for communication between the -C calling program and external user routines. -C They are not altered by DMATD. -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C JACD, RES, DGEFA, DGBFA -C -C***END PROLOGUE DMATD -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),DELTA(*),EWT(*),E(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - EXTERNAL RES, JACD -C - PARAMETER (LML=1, LMU=2, LMTYPE=4, LNRE=12, LNPD=22, LLCIWP=30) -C - LIPVT = IWM(LLCIWP) - IER = 0 - MTYPE=IWM(LMTYPE) - GO TO (100,200,300,400,500),MTYPE -C -C -C Dense user-supplied matrix. -C -100 LENPD=IWM(LNPD) - DO 110 I=1,LENPD -110 WM(I)=0.0D0 - CALL JACD(X,Y,YPRIME,WM,CJ,RPAR,IPAR) - GO TO 230 -C -C -C Dense finite-difference-generated matrix. -C -200 IRES=0 - NROW=0 - SQUR = SQRT(UROUND) - DO 210 I=1,NEQ - DEL=SQUR*MAX(ABS(Y(I)),ABS(H*YPRIME(I)), - * ABS(1.D0/EWT(I))) - DEL=SIGN(DEL,H*YPRIME(I)) - DEL=(Y(I)+DEL)-Y(I) - YSAVE=Y(I) - YPSAVE=YPRIME(I) - Y(I)=Y(I)+DEL - YPRIME(I)=YPRIME(I)+CJ*DEL - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,E,IRES,RPAR,IPAR) - IF (IRES .LT. 0) RETURN - DELINV=1.0D0/DEL - DO 220 L=1,NEQ -220 WM(NROW+L)=(E(L)-DELTA(L))*DELINV - NROW=NROW+NEQ - Y(I)=YSAVE - YPRIME(I)=YPSAVE -210 CONTINUE -C -C -C Do dense-matrix LU decomposition on J. -C -230 CALL DGEFA(WM,NEQ,NEQ,IWM(LIPVT),IER) - RETURN -C -C -C Dummy section for IWM(MTYPE)=3. -C -300 RETURN -C -C -C Banded user-supplied matrix. -C -400 LENPD=IWM(LNPD) - DO 410 I=1,LENPD -410 WM(I)=0.0D0 - CALL JACD(X,Y,YPRIME,WM,CJ,RPAR,IPAR) - MEBAND=2*IWM(LML)+IWM(LMU)+1 - GO TO 550 -C -C -C Banded finite-difference-generated matrix. -C -500 MBAND=IWM(LML)+IWM(LMU)+1 - MBA=MIN0(MBAND,NEQ) - MEBAND=MBAND+IWM(LML) - MEB1=MEBAND-1 - MSAVE=(NEQ/MBAND)+1 - ISAVE=IWM(LNPD) - IPSAVE=ISAVE+MSAVE - IRES=0 - SQUR=SQRT(UROUND) - DO 540 J=1,MBA - DO 510 N=J,NEQ,MBAND - K= (N-J)/MBAND + 1 - WM(ISAVE+K)=Y(N) - WM(IPSAVE+K)=YPRIME(N) - DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)), - * ABS(1.D0/EWT(N))) - DEL=SIGN(DEL,H*YPRIME(N)) - DEL=(Y(N)+DEL)-Y(N) - Y(N)=Y(N)+DEL -510 YPRIME(N)=YPRIME(N)+CJ*DEL - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,E,IRES,RPAR,IPAR) - IF (IRES .LT. 0) RETURN - DO 530 N=J,NEQ,MBAND - K= (N-J)/MBAND + 1 - Y(N)=WM(ISAVE+K) - YPRIME(N)=WM(IPSAVE+K) - DEL=SQUR*MAX(ABS(Y(N)),ABS(H*YPRIME(N)), - * ABS(1.D0/EWT(N))) - DEL=SIGN(DEL,H*YPRIME(N)) - DEL=(Y(N)+DEL)-Y(N) - DELINV=1.0D0/DEL - I1=MAX0(1,(N-IWM(LMU))) - I2=MIN0(NEQ,(N+IWM(LML))) - II=N*MEB1-IWM(LML) - DO 520 I=I1,I2 -520 WM(II+I)=(E(I)-DELTA(I))*DELINV -530 CONTINUE -540 CONTINUE -C -C -C Do LU decomposition of banded J. -C -550 CALL DGBFA (WM,MEBAND,NEQ,IWM(LML),IWM(LMU),IWM(LIPVT),IER) - RETURN -C -C------END OF SUBROUTINE DMATD------------------------------------------ - END - SUBROUTINE DSLVD(NEQ,DELTA,WM,IWM) -C -C***BEGIN PROLOGUE DSLVD -C***REFER TO DDASPK -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940701 (YYMMDD) (new LIPVT) -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine manages the solution of the linear -C system arising in the Newton iteration. -C Real matrix information and real temporary storage -C is stored in the array WM. -C Integer matrix information is stored in the array IWM. -C For a dense matrix, the LINPACK routine DGESL is called. -C For a banded matrix, the LINPACK routine DGBSL is called. -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DGESL, DGBSL -C -C***END PROLOGUE DSLVD -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION DELTA(*),WM(*),IWM(*) -C - PARAMETER (LML=1, LMU=2, LMTYPE=4, LLCIWP=30) -C - LIPVT = IWM(LLCIWP) - MTYPE=IWM(LMTYPE) - GO TO(100,100,300,400,400),MTYPE -C -C Dense matrix. -C -100 CALL DGESL(WM,NEQ,NEQ,IWM(LIPVT),DELTA,0) - RETURN -C -C Dummy section for MTYPE=3. -C -300 CONTINUE - RETURN -C -C Banded matrix. -C -400 MEBAND=2*IWM(LML)+IWM(LMU)+1 - CALL DGBSL(WM,MEBAND,NEQ,IWM(LML), - * IWM(LMU),IWM(LIPVT),DELTA,0) - RETURN -C -C------END OF SUBROUTINE DSLVD------------------------------------------ - END - SUBROUTINE DDASIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,JACK,PSOL,H,TSCALE, - * WT,JSKIP,RPAR,IPAR,SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,UROUND, - * EPLI,SQRTN,RSQRTN,EPCON,RATEMX,STPTOL,JFLG, - * ICNFLG,ICNSTR,IERNLS) -C -C***BEGIN PROLOGUE DDASIK -C***REFER TO DDASPK -C***DATE WRITTEN 941026 (YYMMDD) -C***REVISION DATE 950808 (YYMMDD) -C***REVISION DATE 951110 Removed unreachable block 390. -C***REVISION DATE 000628 TSCALE argument added. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C -C DDASIK solves a nonlinear system of algebraic equations of the -C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in -C the initial conditions. -C -C An initial value for Y and initial guess for YPRIME are input. -C -C The method used is a Newton scheme with Krylov iteration and a -C linesearch algorithm. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector at x. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of equations to be integrated. -C ICOPT -- Initial condition option chosen (1 or 2). -C ID -- Array of dimension NEQ, which must be initialized -C if ICOPT = 1. See DDASIC. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C JACK -- External user-supplied routine to update -C the preconditioner. (This is optional). -C See JAC description for the case -C INFO(12) = 1 in the DDASPK prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C (This is optional). See explanation inside DDASPK. -C H -- Scaling factor for this initial condition calc. -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C WT -- Vector of weights for error criterion. -C JSKIP -- input flag to signal if initial JAC call is to be -C skipped. 1 => skip the call, 0 => do not skip call. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C SAVR -- Work vector for DDASIK of length NEQ. -C DELTA -- Work vector for DDASIK of length NEQ. -C R -- Work vector for DDASIK of length NEQ. -C YIC,YPIC -- Work vectors for DDASIK, each of length NEQ. -C PWK -- Work vector for DDASIK of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information for linear system -C solvers, and various other information. -C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). -C UROUND -- Unit roundoff. Not used here. -C EPLI -- convergence test constant. -C See DDASPK prologue for more details. -C SQRTN -- Square root of NEQ. -C RSQRTN -- reciprical of square root of NEQ. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C RATEMX -- Maximum convergence rate for which Newton iteration -C is considered converging. -C JFLG -- Flag showing whether a Jacobian routine is supplied. -C ICNFLG -- Integer scalar. If nonzero, then constraint -C violations in the proposed new approximate solution -C will be checked for, and the maximum step length -C will be adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C IERNLS -- Error flag for nonlinear solver. -C 0 ==> nonlinear solver converged. -C 1,2 ==> recoverable error inside nonlinear solver. -C 1 => retry with current Y, YPRIME -C 2 => retry with original Y, YPRIME -C -1 ==> unrecoverable error in nonlinear solver. -C -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C RES, JACK, DNSIK, DCOPY -C -C***END PROLOGUE DDASIK -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),ID(*),WT(*),ICNSTR(*) - DIMENSION SAVR(*),DELTA(*),R(*),YIC(*),YPIC(*),PWK(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - EXTERNAL RES, JACK, PSOL -C - PARAMETER (LNRE=12, LNJE=13, LLOCWP=29, LLCIWP=30) - PARAMETER (LMXNIT=32, LMXNJ=33) -C -C -C Perform initializations. -C - LWP = IWM(LLOCWP) - LIWP = IWM(LLCIWP) - MXNIT = IWM(LMXNIT) - MXNJ = IWM(LMXNJ) - IERNLS = 0 - NJ = 0 - EPLIN = EPLI*EPCON -C -C Call RES to initialize DELTA. -C - IRES = 0 - IWM(LNRE) = IWM(LNRE) + 1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 370 -C -C Looping point for updating the preconditioner. -C - 300 CONTINUE -C -C Initialize all error flags to zero. -C - IERPJ = 0 - IRES = 0 - IERNEW = 0 -C -C If a Jacobian routine was supplied, call it. -C - IF (JFLG .EQ. 1 .AND. JSKIP .EQ. 0) THEN - NJ = NJ + 1 - IWM(LNJE)=IWM(LNJE)+1 - CALL JACK (RES, IRES, NEQ, X, Y, YPRIME, WT, DELTA, R, H, CJ, - * WM(LWP), IWM(LIWP), IERPJ, RPAR, IPAR) - IF (IRES .LT. 0 .OR. IERPJ .NE. 0) GO TO 370 - ENDIF - JSKIP = 0 -C -C Call the nonlinear Newton solver for up to MXNIT iterations. -C - CALL DNSIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,PSOL,WT,RPAR,IPAR, - * SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,TSCALE,SQRTN,RSQRTN, - * EPLIN,EPCON,RATEMX,MXNIT,STPTOL,ICNFLG,ICNSTR,IERNEW) -C - IF (IERNEW .EQ. 1 .AND. NJ .LT. MXNJ .AND. JFLG .EQ. 1) THEN -C -C Up to MXNIT iterations were done, the convergence rate is < 1, -C a Jacobian routine is supplied, and the number of JACK calls -C is less than MXNJ. -C Copy the residual SAVR to DELTA, call JACK, and try again. -C - CALL DCOPY (NEQ, SAVR, 1, DELTA, 1) - GO TO 300 - ENDIF -C - IF (IERNEW .NE. 0) GO TO 380 - RETURN -C -C -C Unsuccessful exits from nonlinear solver. -C Set IERNLS accordingly. -C - 370 IERNLS = 2 - IF (IRES .LE. -2) IERNLS = -1 - RETURN -C - 380 IERNLS = MIN(IERNEW,2) - RETURN -C -C----------------------- END OF SUBROUTINE DDASIK----------------------- - END - SUBROUTINE DNSIK(X,Y,YPRIME,NEQ,ICOPT,ID,RES,PSOL,WT,RPAR,IPAR, - * SAVR,DELTA,R,YIC,YPIC,PWK,WM,IWM,CJ,TSCALE,SQRTN,RSQRTN,EPLIN, - * EPCON,RATEMX,MAXIT,STPTOL,ICNFLG,ICNSTR,IERNEW) -C -C***BEGIN PROLOGUE DNSIK -C***REFER TO DDASPK -C***DATE WRITTEN 940701 (YYMMDD) -C***REVISION DATE 950714 (YYMMDD) -C***REVISION DATE 000628 TSCALE argument added. -C***REVISION DATE 000628 Added criterion for IERNEW = 1 return. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNSIK solves a nonlinear system of algebraic equations of the -C form G(X,Y,YPRIME) = 0 for the unknown parts of Y and YPRIME in -C the initial conditions. -C -C The method used is a Newton scheme combined with a linesearch -C algorithm, using Krylov iterative linear system methods. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C ICOPT -- Initial condition option chosen (1 or 2). -C ID -- Array of dimension NEQ, which must be initialized -C if ICOPT = 1. See DDASIC. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C See explanation inside DDASPK. -C WT -- Vector of weights for error criterion. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C SAVR -- Work vector for DNSIK of length NEQ. -C DELTA -- Residual vector on entry, and work vector of -C length NEQ for DNSIK. -C R -- Work vector for DNSIK of length NEQ. -C YIC,YPIC -- Work vectors for DNSIK, each of length NEQ. -C PWK -- Work vector for DNSIK of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information such as the matrix -C of partial derivatives, permutation -C vector, and various other information. -C CJ -- Matrix parameter = 1/H (ICOPT = 1) or 0 (ICOPT = 2). -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C SQRTN -- Square root of NEQ. -C RSQRTN -- reciprical of square root of NEQ. -C EPLIN -- Tolerance for linear system solver. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C RATEMX -- Maximum convergence rate for which Newton iteration -C is considered converging. -C MAXIT -- Maximum allowed number of Newton iterations. -C STPTOL -- Tolerance used in calculating the minimum lambda -C value allowed. -C ICNFLG -- Integer scalar. If nonzero, then constraint -C violations in the proposed new approximate solution -C will be checked for, and the maximum step length -C will be adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C IERNEW -- Error flag for Newton iteration. -C 0 ==> Newton iteration converged. -C 1 ==> failed to converge, but RATE .lt. 1, or the -C residual norm was reduced by a factor of .1. -C 2 ==> failed to converge, RATE .gt. RATEMX. -C 3 ==> other recoverable error. -C -1 ==> unrecoverable error inside Newton iteration. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C DFNRMK, DSLVK, DDWNRM, DLINSK, DCOPY -C -C***END PROLOGUE DNSIK -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*),ID(*),DELTA(*),R(*),SAVR(*) - DIMENSION YIC(*),YPIC(*),PWK(*),WM(*),IWM(*), RPAR(*),IPAR(*) - DIMENSION ICNSTR(*) - EXTERNAL RES, PSOL -C - PARAMETER (LNNI=19, LNPS=21, LLOCWP=29, LLCIWP=30) - PARAMETER (LLSOFF=35, LSTOL=14) -C -C -C Initializations. M is the Newton iteration counter. -C - LSOFF = IWM(LLSOFF) - M = 0 - RATE = 1.0D0 - LWP = IWM(LLOCWP) - LIWP = IWM(LLCIWP) - RLX = 0.4D0 -C -C Save residual in SAVR. -C - CALL DCOPY (NEQ, DELTA, 1, SAVR, 1) -C -C Compute norm of (P-inverse)*(residual). -C - CALL DFNRMK (NEQ, Y, X, YPRIME, SAVR, R, CJ, TSCALE, WT, - * SQRTN, RSQRTN, RES, IRES, PSOL, 1, IER, FNRM, EPLIN, - * WM(LWP), IWM(LIWP), PWK, RPAR, IPAR) - IWM(LNPS) = IWM(LNPS) + 1 - IF (IER .NE. 0) THEN - IERNEW = 3 - RETURN - ENDIF -C -C Return now if residual norm is .le. EPCON. -C - IF (FNRM .LE. EPCON) RETURN -C -C Newton iteration loop. -C - FNRM0 = FNRM -300 CONTINUE - IWM(LNNI) = IWM(LNNI) + 1 -C -C Compute a new step vector DELTA. -C - CALL DSLVK (NEQ, Y, X, YPRIME, SAVR, DELTA, WT, WM, IWM, - * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, - * RPAR, IPAR) - IF (IRES .NE. 0 .OR. IERSL .NE. 0) GO TO 390 -C -C Get norm of DELTA. Return now if DELTA is zero. -C - DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (DELNRM .EQ. 0.0D0) RETURN -C -C Call linesearch routine for global strategy and set RATE. -C - OLDFNM = FNRM -C - CALL DLINSK (NEQ, Y, X, YPRIME, SAVR, CJ, TSCALE, DELTA, DELNRM, - * WT, SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL, - * WM, IWM, RHOK, FNRM, ICOPT, ID, WM(LWP), IWM(LIWP), R, EPLIN, - * YIC, YPIC, PWK, ICNFLG, ICNSTR, RLX, RPAR, IPAR) -C - RATE = FNRM/OLDFNM -C -C Check for error condition from linesearch. - IF (IRET .NE. 0) GO TO 390 -C -C Test for convergence of the iteration, and return or loop. -C - IF (FNRM .LE. EPCON) RETURN -C -C The iteration has not yet converged. Update M. -C Test whether the maximum number of iterations have been tried. -C - M = M + 1 - IF(M .GE. MAXIT) GO TO 380 -C -C Copy the residual SAVR to DELTA and loop for another iteration. -C - CALL DCOPY (NEQ, SAVR, 1, DELTA, 1) - GO TO 300 -C -C The maximum number of iterations was done. Set IERNEW and return. -C -380 IF (RATE .LE. RATEMX .OR. FNRM .LE. 0.1D0*FNRM0) THEN - IERNEW = 1 - ELSE - IERNEW = 2 - ENDIF - RETURN -C -390 IF (IRES .LE. -2 .OR. IERSL .LT. 0) THEN - IERNEW = -1 - ELSE - IERNEW = 3 - IF (IRES .EQ. 0 .AND. IERSL .EQ. 1 .AND. M .GE. 2 - 1 .AND. RATE .LT. 1.0D0) IERNEW = 1 - ENDIF - RETURN -C -C -C----------------------- END OF SUBROUTINE DNSIK------------------------ - END - SUBROUTINE DLINSK (NEQ, Y, T, YPRIME, SAVR, CJ, TSCALE, P, PNRM, - * WT, SQRTN, RSQRTN, LSOFF, STPTOL, IRET, RES, IRES, PSOL, - * WM, IWM, RHOK, FNRM, ICOPT, ID, WP, IWP, R, EPLIN, YNEW, YPNEW, - * PWK, ICNFLG, ICNSTR, RLX, RPAR, IPAR) -C -C***BEGIN PROLOGUE DLINSK -C***REFER TO DNSIK -C***DATE WRITTEN 940830 (YYMMDD) -C***REVISION DATE 951006 (Arguments SQRTN, RSQRTN added.) -C***REVISION DATE 960129 Moved line RL = ONE to top block. -C***REVISION DATE 000628 TSCALE argument added. -C***REVISION DATE 000628 RHOK*RHOK term removed in alpha test. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DLINSK uses a linesearch algorithm to calculate a new (Y,YPRIME) -C pair (YNEW,YPNEW) such that -C -C f(YNEW,YPNEW) .le. (1 - 2*ALPHA*RL)*f(Y,YPRIME) -C -C where 0 < RL <= 1, and RHOK is the scaled preconditioned norm of -C the final residual vector in the Krylov iteration. -C Here, f(y,y') is defined as -C -C f(y,y') = (1/2)*norm( (P-inverse)*G(t,y,y') )**2 , -C -C where norm() is the weighted RMS vector norm, G is the DAE -C system residual function, and P is the preconditioner used -C in the Krylov iteration. -C -C In addition to the parameters defined elsewhere, we have -C -C SAVR -- Work array of length NEQ, containing the residual -C vector G(t,y,y') on return. -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C P -- Approximate Newton step used in backtracking. -C PNRM -- Weighted RMS norm of P. -C LSOFF -- Flag showing whether the linesearch algorithm is -C to be invoked. 0 means do the linesearch, -C 1 means turn off linesearch. -C STPTOL -- Tolerance used in calculating the minimum lambda -C value allowed. -C ICNFLG -- Integer scalar. If nonzero, then constraint violations -C in the proposed new approximate solution will be -C checked for, and the maximum step length will be -C adjusted accordingly. -C ICNSTR -- Integer array of length NEQ containing flags for -C checking constraints. -C RHOK -- Weighted norm of preconditioned Krylov residual. -C RLX -- Real scalar restricting update size in DCNSTR. -C YNEW -- Array of length NEQ used to hold the new Y in -C performing the linesearch. -C YPNEW -- Array of length NEQ used to hold the new YPRIME in -C performing the linesearch. -C PWK -- Work vector of length NEQ for use in PSOL. -C Y -- Array of length NEQ containing the new Y (i.e.,=YNEW). -C YPRIME -- Array of length NEQ containing the new YPRIME -C (i.e.,=YPNEW). -C FNRM -- Real scalar containing SQRT(2*f(Y,YPRIME)) for the -C current (Y,YPRIME) on input and output. -C R -- Work space length NEQ for residual vector. -C IRET -- Return flag. -C IRET=0 means that a satisfactory (Y,YPRIME) was found. -C IRET=1 means that the routine failed to find a new -C (Y,YPRIME) that was sufficiently distinct from -C the current (Y,YPRIME) pair. -C IRET=2 means a failure in RES or PSOL. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C DFNRMK, DYYPNW, DCNSTR, DCOPY, XERRWD -C -C***END PROLOGUE DLINSK -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - EXTERNAL RES, PSOL - DIMENSION Y(*), YPRIME(*), P(*), WT(*), SAVR(*), R(*), ID(*) - DIMENSION WM(*), IWM(*), YNEW(*), YPNEW(*), PWK(*), ICNSTR(*) - DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*) - CHARACTER MSG*80 -C - PARAMETER (LNRE=12, LNPS=21, LKPRIN=31) -C - SAVE ALPHA, ONE, TWO - DATA ALPHA/1.0D-4/, ONE/1.0D0/, TWO/2.0D0/ -C - KPRIN=IWM(LKPRIN) - F1NRM = (FNRM*FNRM)/TWO - RATIO = ONE -C - IF (KPRIN .GE. 2) THEN - MSG = '------ IN ROUTINE DLINSK-- PNRM = (R1)' - CALL XERRWD(MSG, 38, 921, 0, 0, 0, 0, 1, PNRM, 0.0D0) - ENDIF - TAU = PNRM - RL = ONE -C----------------------------------------------------------------------- -C Check for violations of the constraints, if any are imposed. -C If any violations are found, the step vector P is rescaled, and the -C constraint check is repeated, until no violations are found. -C----------------------------------------------------------------------- - IF (ICNFLG .NE. 0) THEN - 10 CONTINUE - CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) - CALL DCNSTR (NEQ, Y, YNEW, ICNSTR, TAU, RLX, IRET, IVAR) - IF (IRET .EQ. 1) THEN - RATIO1 = TAU/PNRM - RATIO = RATIO*RATIO1 - DO 20 I = 1,NEQ - 20 P(I) = P(I)*RATIO1 - PNRM = TAU - IF (KPRIN .GE. 2) THEN - MSG = '------ CONSTRAINT VIOL., PNRM = (R1), INDEX = (I1)' - CALL XERRWD(MSG, 50, 922, 0, 1, IVAR, 0, 1, PNRM, 0.0D0) - ENDIF - IF (PNRM .LE. STPTOL) THEN - IRET = 1 - RETURN - ENDIF - GO TO 10 - ENDIF - ENDIF -C - SLPI = -TWO*F1NRM*RATIO - RLMIN = STPTOL/PNRM - IF (LSOFF .EQ. 0 .AND. KPRIN .GE. 2) THEN - MSG = '------ MIN. LAMBDA = (R1)' - CALL XERRWD(MSG, 25, 923, 0, 0, 0, 0, 1, RLMIN, 0.0D0) - ENDIF -C----------------------------------------------------------------------- -C Begin iteration to find RL value satisfying alpha-condition. -C Update YNEW and YPNEW, then compute norm of new scaled residual and -C perform alpha condition test. -C----------------------------------------------------------------------- - 100 CONTINUE - CALL DYYPNW (NEQ,Y,YPRIME,CJ,RL,P,ICOPT,ID,YNEW,YPNEW) - CALL DFNRMK (NEQ, YNEW, T, YPNEW, SAVR, R, CJ, TSCALE, WT, - * SQRTN, RSQRTN, RES, IRES, PSOL, 0, IER, FNRMP, EPLIN, - * WP, IWP, PWK, RPAR, IPAR) - IWM(LNRE) = IWM(LNRE) + 1 - IF (IRES .GE. 0) IWM(LNPS) = IWM(LNPS) + 1 - IF (IRES .NE. 0 .OR. IER .NE. 0) THEN - IRET = 2 - RETURN - ENDIF - IF (LSOFF .EQ. 1) GO TO 150 -C - F1NRMP = FNRMP*FNRMP/TWO - IF (KPRIN .GE. 2) THEN - MSG = '------ LAMBDA = (R1)' - CALL XERRWD(MSG, 20, 924, 0, 0, 0, 0, 1, RL, 0.0D0) - MSG = '------ NORM(F1) = (R1), NORM(F1NEW) = (R2)' - CALL XERRWD(MSG, 43, 925, 0, 0, 0, 0, 2, F1NRM, F1NRMP) - ENDIF - IF (F1NRMP .GT. F1NRM + ALPHA*SLPI*RL) GO TO 200 -C----------------------------------------------------------------------- -C Alpha-condition is satisfied, or linesearch is turned off. -C Copy YNEW,YPNEW to Y,YPRIME and return. -C----------------------------------------------------------------------- - 150 IRET = 0 - CALL DCOPY(NEQ, YNEW, 1, Y, 1) - CALL DCOPY(NEQ, YPNEW, 1, YPRIME, 1) - FNRM = FNRMP - IF (KPRIN .GE. 1) THEN - MSG = '------ LEAVING ROUTINE DLINSK, FNRM = (R1)' - CALL XERRWD(MSG, 42, 926, 0, 0, 0, 0, 1, FNRM, 0.0D0) - ENDIF - RETURN -C----------------------------------------------------------------------- -C Alpha-condition not satisfied. Perform backtrack to compute new RL -C value. If RL is less than RLMIN, i.e. no satisfactory YNEW,YPNEW can -C be found sufficiently distinct from Y,YPRIME, then return IRET = 1. -C----------------------------------------------------------------------- - 200 CONTINUE - IF (RL .LT. RLMIN) THEN - IRET = 1 - RETURN - ENDIF -C - RL = RL/TWO - GO TO 100 -C -C----------------------- END OF SUBROUTINE DLINSK ---------------------- - END - SUBROUTINE DFNRMK (NEQ, Y, T, YPRIME, SAVR, R, CJ, TSCALE, WT, - * SQRTN, RSQRTN, RES, IRES, PSOL, IRIN, IER, - * FNORM, EPLIN, WP, IWP, PWK, RPAR, IPAR) -C -C***BEGIN PROLOGUE DFNRMK -C***REFER TO DLINSK -C***DATE WRITTEN 940830 (YYMMDD) -C***REVISION DATE 951006 (SQRTN, RSQRTN, and scaling of WT added.) -C***REVISION DATE 000628 TSCALE argument added. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DFNRMK calculates the scaled preconditioned norm of the nonlinear -C function used in the nonlinear iteration for obtaining consistent -C initial conditions. Specifically, DFNRMK calculates the weighted -C root-mean-square norm of the vector (P-inverse)*G(T,Y,YPRIME), -C where P is the preconditioner matrix. -C -C In addition to the parameters described in the calling program -C DLINSK, the parameters represent -C -C TSCALE -- Scale factor in T, used for stopping tests if nonzero. -C IRIN -- Flag showing whether the current residual vector is -C input in SAVR. 1 means it is, 0 means it is not. -C R -- Array of length NEQ that contains -C (P-inverse)*G(T,Y,YPRIME) on return. -C FNORM -- Scalar containing the weighted norm of R on return. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C RES, DCOPY, DSCAL, PSOL, DDWNRM -C -C***END PROLOGUE DFNRMK -C -C - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - EXTERNAL RES, PSOL - DIMENSION Y(*), YPRIME(*), WT(*), SAVR(*), R(*), PWK(*) - DIMENSION WP(*), IWP(*), RPAR(*), IPAR(*) -C----------------------------------------------------------------------- -C Call RES routine if IRIN = 0. -C----------------------------------------------------------------------- - IF (IRIN .EQ. 0) THEN - IRES = 0 - CALL RES (T, Y, YPRIME, CJ, SAVR, IRES, RPAR, IPAR) - IF (IRES .LT. 0) RETURN - ENDIF -C----------------------------------------------------------------------- -C Apply inverse of left preconditioner to vector R. -C First scale WT array by 1/sqrt(N), and undo scaling afterward. -C----------------------------------------------------------------------- - CALL DCOPY(NEQ, SAVR, 1, R, 1) - CALL DSCAL (NEQ, RSQRTN, WT, 1) - IER = 0 - CALL PSOL (NEQ, T, Y, YPRIME, SAVR, PWK, CJ, WT, WP, IWP, - * R, EPLIN, IER, RPAR, IPAR) - CALL DSCAL (NEQ, SQRTN, WT, 1) - IF (IER .NE. 0) RETURN -C----------------------------------------------------------------------- -C Calculate norm of R. -C----------------------------------------------------------------------- - FNORM = DDWNRM (NEQ, R, WT, RPAR, IPAR) - IF (TSCALE .GT. 0.0D0) FNORM = FNORM*TSCALE*ABS(CJ) -C - RETURN -C----------------------- END OF SUBROUTINE DFNRMK ---------------------- - END - SUBROUTINE DNEDK(X,Y,YPRIME,NEQ,RES,JACK,PSOL, - * H,WT,JSTART,IDID,RPAR,IPAR,PHI,GAMMA,SAVR,DELTA,E, - * WM,IWM,CJ,CJOLD,CJLAST,S,UROUND,EPLI,SQRTN,RSQRTN, - * EPCON,JCALC,JFLG,KP1,NONNEG,NTYPE,IERNLS) -C -C***BEGIN PROLOGUE DNEDK -C***REFER TO DDASPK -C***DATE WRITTEN 891219 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940701 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNEDK solves a nonlinear system of -C algebraic equations of the form -C G(X,Y,YPRIME) = 0 for the unknown Y. -C -C The method used is a matrix-free Newton scheme. -C -C The parameters represent -C X -- Independent variable. -C Y -- Solution vector at x. -C YPRIME -- Derivative of solution vector -C after successful step. -C NEQ -- Number of equations to be integrated. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C JACK -- External user-supplied routine to update -C the preconditioner. (This is optional). -C See JAC description for the case -C INFO(12) = 1 in the DDASPK prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C (This is optional). See explanation inside DDASPK. -C H -- Appropriate step size for this step. -C WT -- Vector of weights for error criterion. -C JSTART -- Indicates first call to this routine. -C If JSTART = 0, then this is the first call, -C otherwise it is not. -C IDID -- Completion flag, output by DNEDK. -C See IDID description in DDASPK prologue. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C PHI -- Array of divided differences used by -C DNEDK. The length is NEQ*(K+1), where -C K is the maximum order. -C GAMMA -- Array used to predict Y and YPRIME. The length -C is K+1, where K is the maximum order. -C SAVR -- Work vector for DNEDK of length NEQ. -C DELTA -- Work vector for DNEDK of length NEQ. -C E -- Error accumulation vector for DNEDK of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information for linear system -C solvers, and various other information. -C CJ -- Parameter always proportional to 1/H. -C CJOLD -- Saves the value of CJ as of the last call to DITMD. -C Accounts for changes in CJ needed to -C decide whether to call DITMD. -C CJLAST -- Previous value of CJ. -C S -- A scalar determined by the approximate rate -C of convergence of the Newton iteration and used -C in the convergence test for the Newton iteration. -C -C If RATE is defined to be an estimate of the -C rate of convergence of the Newton iteration, -C then S = RATE/(1.D0-RATE). -C -C The closer RATE is to 0., the faster the Newton -C iteration is converging; the closer RATE is to 1., -C the slower the Newton iteration is converging. -C -C On the first Newton iteration with an up-dated -C preconditioner S = 100.D0, Thus the initial -C RATE of convergence is approximately 1. -C -C S is preserved from call to call so that the rate -C estimate from a previous step can be applied to -C the current step. -C UROUND -- Unit roundoff. Not used here. -C EPLI -- convergence test constant. -C See DDASPK prologue for more details. -C SQRTN -- Square root of NEQ. -C RSQRTN -- reciprical of square root of NEQ. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C JCALC -- Flag used to determine when to update -C the Jacobian matrix. In general: -C -C JCALC = -1 ==> Call the DITMD routine to update -C the Jacobian matrix. -C JCALC = 0 ==> Jacobian matrix is up-to-date. -C JCALC = 1 ==> Jacobian matrix is out-dated, -C but DITMD will not be called unless -C JCALC is set to -1. -C JFLG -- Flag showing whether a Jacobian routine is supplied. -C KP1 -- The current order + 1; updated across calls. -C NONNEG -- Flag to determine nonnegativity constraints. -C NTYPE -- Identification code for the DNEDK routine. -C 1 ==> modified Newton; iterative linear solver. -C 2 ==> modified Newton; user-supplied linear solver. -C IERNLS -- Error flag for nonlinear solver. -C 0 ==> nonlinear solver converged. -C 1 ==> recoverable error inside non-linear solver. -C -1 ==> unrecoverable error inside non-linear solver. -C -C The following group of variables are passed as arguments to -C the Newton iteration solver. They are explained in greater detail -C in DNSK: -C TOLNEW, MULDEL, MAXIT, IERNEW -C -C IERTYP -- Flag which tells whether this subroutine is correct. -C 0 ==> correct subroutine. -C 1 ==> incorrect subroutine. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C RES, JACK, DDWNRM, DNSK -C -C***END PROLOGUE DNEDK -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*) - DIMENSION PHI(NEQ,*),SAVR(*),DELTA(*),E(*) - DIMENSION WM(*),IWM(*) - DIMENSION GAMMA(*),RPAR(*),IPAR(*) - EXTERNAL RES, JACK, PSOL -C - PARAMETER (LNRE=12, LNJE=13, LLOCWP=29, LLCIWP=30) -C - SAVE MULDEL, MAXIT, XRATE - DATA MULDEL/0/, MAXIT/4/, XRATE/0.25D0/ -C -C Verify that this is the correct subroutine. -C - IERTYP = 0 - IF (NTYPE .NE. 1) THEN - IERTYP = 1 - GO TO 380 - ENDIF -C -C If this is the first step, perform initializations. -C - IF (JSTART .EQ. 0) THEN - CJOLD = CJ - JCALC = -1 - S = 100.D0 - ENDIF -C -C Perform all other initializations. -C - IERNLS = 0 - LWP = IWM(LLOCWP) - LIWP = IWM(LLCIWP) -C -C Decide whether to update the preconditioner. -C - IF (JFLG .NE. 0) THEN - TEMP1 = (1.0D0 - XRATE)/(1.0D0 + XRATE) - TEMP2 = 1.0D0/TEMP1 - IF (CJ/CJOLD .LT. TEMP1 .OR. CJ/CJOLD .GT. TEMP2) JCALC = -1 - IF (CJ .NE. CJLAST) S = 100.D0 - ELSE - JCALC = 0 - ENDIF -C -C Looping point for updating preconditioner with current stepsize. -C -300 CONTINUE -C -C Initialize all error flags to zero. -C - IERPJ = 0 - IRES = 0 - IERSL = 0 - IERNEW = 0 -C -C Predict the solution and derivative and compute the tolerance -C for the Newton iteration. -C - DO 310 I=1,NEQ - Y(I)=PHI(I,1) -310 YPRIME(I)=0.0D0 - DO 330 J=2,KP1 - DO 320 I=1,NEQ - Y(I)=Y(I)+PHI(I,J) -320 YPRIME(I)=YPRIME(I)+GAMMA(J)*PHI(I,J) -330 CONTINUE - EPLIN = EPLI*EPCON - TOLNEW = EPLIN -C -C Call RES to initialize DELTA. -C - IWM(LNRE)=IWM(LNRE)+1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 -C -C -C If indicated, update the preconditioner. -C Set JCALC to 0 as an indicator that this has been done. -C - IF(JCALC .EQ. -1)THEN - IWM(LNJE) = IWM(LNJE) + 1 - JCALC=0 - CALL JACK (RES, IRES, NEQ, X, Y, YPRIME, WT, DELTA, E, H, CJ, - * WM(LWP), IWM(LIWP), IERPJ, RPAR, IPAR) - CJOLD=CJ - S = 100.D0 - IF (IRES .LT. 0) GO TO 380 - IF (IERPJ .NE. 0) GO TO 380 - ENDIF -C -C Call the nonlinear Newton solver. -C - CALL DNSK(X,Y,YPRIME,NEQ,RES,PSOL,WT,RPAR,IPAR,SAVR, - * DELTA,E,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON, - * S,TEMP1,TOLNEW,MULDEL,MAXIT,IRES,IERSL,IERNEW) -C - IF (IERNEW .GT. 0 .AND. JCALC .NE. 0) THEN -C -C The Newton iteration had a recoverable failure with an old -C preconditioner. Retry the step with a new preconditioner. -C - JCALC = -1 - GO TO 300 - ENDIF -C - IF (IERNEW .NE. 0) GO TO 380 -C -C The Newton iteration has converged. If nonnegativity of -C solution is required, set the solution nonnegative, if the -C perturbation to do it is small enough. If the change is too -C large, then consider the corrector iteration to have failed. -C - IF(NONNEG .EQ. 0) GO TO 390 - DO 360 I = 1,NEQ - 360 DELTA(I) = MIN(Y(I),0.0D0) - DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - IF(DELNRM .GT. EPCON) GO TO 380 - DO 370 I = 1,NEQ - 370 E(I) = E(I) - DELTA(I) - GO TO 390 -C -C -C Exits from nonlinear solver. -C No convergence with current preconditioner. -C Compute IERNLS and IDID accordingly. -C -380 CONTINUE - IF (IRES .LE. -2 .OR. IERSL .LT. 0 .OR. IERTYP .NE. 0) THEN - IERNLS = -1 - IF (IRES .LE. -2) IDID = -11 - IF (IERSL .LT. 0) IDID = -13 - IF (IERTYP .NE. 0) IDID = -15 - ELSE - IERNLS = 1 - IF (IRES .EQ. -1) IDID = -10 - IF (IERPJ .NE. 0) IDID = -5 - IF (IERSL .GT. 0) IDID = -14 - ENDIF -C -C -390 JCALC = 1 - RETURN -C -C------END OF SUBROUTINE DNEDK------------------------------------------ - END - SUBROUTINE DNSK(X,Y,YPRIME,NEQ,RES,PSOL,WT,RPAR,IPAR, - * SAVR,DELTA,E,WM,IWM,CJ,SQRTN,RSQRTN,EPLIN,EPCON, - * S,CONFAC,TOLNEW,MULDEL,MAXIT,IRES,IERSL,IERNEW) -C -C***BEGIN PROLOGUE DNSK -C***REFER TO DDASPK -C***DATE WRITTEN 891219 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 950126 (YYMMDD) -C***REVISION DATE 000711 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DNSK solves a nonlinear system of -C algebraic equations of the form -C G(X,Y,YPRIME) = 0 for the unknown Y. -C -C The method used is a modified Newton scheme. -C -C The parameters represent -C -C X -- Independent variable. -C Y -- Solution vector. -C YPRIME -- Derivative of solution vector. -C NEQ -- Number of unknowns. -C RES -- External user-supplied subroutine -C to evaluate the residual. See RES description -C in DDASPK prologue. -C PSOL -- External user-supplied routine to solve -C a linear system using preconditioning. -C See explanation inside DDASPK. -C WT -- Vector of weights for error criterion. -C RPAR,IPAR -- Real and integer arrays used for communication -C between the calling program and external user -C routines. They are not altered within DASPK. -C SAVR -- Work vector for DNSK of length NEQ. -C DELTA -- Work vector for DNSK of length NEQ. -C E -- Error accumulation vector for DNSK of length NEQ. -C WM,IWM -- Real and integer arrays storing -C matrix information such as the matrix -C of partial derivatives, permutation -C vector, and various other information. -C CJ -- Parameter always proportional to 1/H (step size). -C SQRTN -- Square root of NEQ. -C RSQRTN -- reciprical of square root of NEQ. -C EPLIN -- Tolerance for linear system solver. -C EPCON -- Tolerance to test for convergence of the Newton -C iteration. -C S -- Used for error convergence tests. -C In the Newton iteration: S = RATE/(1.D0-RATE), -C where RATE is the estimated rate of convergence -C of the Newton iteration. -C -C The closer RATE is to 0., the faster the Newton -C iteration is converging; the closer RATE is to 1., -C the slower the Newton iteration is converging. -C -C The calling routine sends the initial value -C of S to the Newton iteration. -C CONFAC -- A residual scale factor to improve convergence. -C TOLNEW -- Tolerance on the norm of Newton correction in -C alternative Newton convergence test. -C MULDEL -- A flag indicating whether or not to multiply -C DELTA by CONFAC. -C 0 ==> do not scale DELTA by CONFAC. -C 1 ==> scale DELTA by CONFAC. -C MAXIT -- Maximum allowed number of Newton iterations. -C IRES -- Error flag returned from RES. See RES description -C in DDASPK prologue. If IRES = -1, then IERNEW -C will be set to 1. -C If IRES < -1, then IERNEW will be set to -1. -C IERSL -- Error flag for linear system solver. -C See IERSL description in subroutine DSLVK. -C If IERSL = 1, then IERNEW will be set to 1. -C If IERSL < 0, then IERNEW will be set to -1. -C IERNEW -- Error flag for Newton iteration. -C 0 ==> Newton iteration converged. -C 1 ==> recoverable error inside Newton iteration. -C -1 ==> unrecoverable error inside Newton iteration. -C----------------------------------------------------------------------- -C -C***ROUTINES CALLED -C RES, DSLVK, DDWNRM -C -C***END PROLOGUE DNSK -C -C - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DIMENSION Y(*),YPRIME(*),WT(*),DELTA(*),E(*),SAVR(*) - DIMENSION WM(*),IWM(*), RPAR(*),IPAR(*) - EXTERNAL RES, PSOL -C - PARAMETER (LNNI=19, LNRE=12) -C -C Initialize Newton counter M and accumulation vector E. -C - M = 0 - DO 100 I=1,NEQ -100 E(I) = 0.0D0 -C -C Corrector loop. -C -300 CONTINUE - IWM(LNNI) = IWM(LNNI) + 1 -C -C If necessary, multiply residual by convergence factor. -C - IF (MULDEL .EQ. 1) THEN - DO 320 I = 1,NEQ -320 DELTA(I) = DELTA(I) * CONFAC - ENDIF -C -C Save residual in SAVR. -C - DO 340 I = 1,NEQ -340 SAVR(I) = DELTA(I) -C -C Compute a new iterate. Store the correction in DELTA. -C - CALL DSLVK (NEQ, Y, X, YPRIME, SAVR, DELTA, WT, WM, IWM, - * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, - * RPAR, IPAR) - IF (IRES .NE. 0 .OR. IERSL .NE. 0) GO TO 380 -C -C Update Y, E, and YPRIME. -C - DO 360 I=1,NEQ - Y(I) = Y(I) - DELTA(I) - E(I) = E(I) - DELTA(I) -360 YPRIME(I) = YPRIME(I) - CJ*DELTA(I) -C -C Test for convergence of the iteration. -C - DELNRM = DDWNRM(NEQ,DELTA,WT,RPAR,IPAR) - IF (M .EQ. 0) THEN - OLDNRM = DELNRM - IF (DELNRM .LE. TOLNEW) GO TO 370 - ELSE - RATE = (DELNRM/OLDNRM)**(1.0D0/M) - IF (RATE .GT. 0.9D0) GO TO 380 - S = RATE/(1.0D0 - RATE) - ENDIF - IF (S*DELNRM .LE. EPCON) GO TO 370 -C -C The corrector has not yet converged. Update M and test whether -C the maximum number of iterations have been tried. -C - M = M + 1 - IF (M .GE. MAXIT) GO TO 380 -C -C Evaluate the residual, and go back to do another iteration. -C - IWM(LNRE) = IWM(LNRE) + 1 - CALL RES(X,Y,YPRIME,CJ,DELTA,IRES,RPAR,IPAR) - IF (IRES .LT. 0) GO TO 380 - GO TO 300 -C -C The iteration has converged. -C -370 RETURN -C -C The iteration has not converged. Set IERNEW appropriately. -C -380 CONTINUE - IF (IRES .LE. -2 .OR. IERSL .LT. 0) THEN - IERNEW = -1 - ELSE - IERNEW = 1 - ENDIF - RETURN -C -C -C------END OF SUBROUTINE DNSK------------------------------------------- - END - SUBROUTINE DSLVK (NEQ, Y, TN, YPRIME, SAVR, X, EWT, WM, IWM, - * RES, IRES, PSOL, IERSL, CJ, EPLIN, SQRTN, RSQRTN, RHOK, - * RPAR, IPAR) -C -C***BEGIN PROLOGUE DSLVK -C***REFER TO DDASPK -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940928 Removed MNEWT and added RHOK in call list. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C DSLVK uses a restart algorithm and interfaces to DSPIGM for -C the solution of the linear system arising from a Newton iteration. -C -C In addition to variables described elsewhere, -C communication with DSLVK uses the following variables.. -C WM = Real work space containing data for the algorithm -C (Krylov basis vectors, Hessenberg matrix, etc.). -C IWM = Integer work space containing data for the algorithm. -C X = The right-hand side vector on input, and the solution vector -C on output, of length NEQ. -C IRES = Error flag from RES. -C IERSL = Output flag .. -C IERSL = 0 means no trouble occurred (or user RES routine -C returned IRES < 0) -C IERSL = 1 means the iterative method failed to converge -C (DSPIGM returned IFLAG > 0.) -C IERSL = -1 means there was a nonrecoverable error in the -C iterative solver, and an error exit will occur. -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DSCAL, DCOPY, DSPIGM -C -C***END PROLOGUE DSLVK -C - INTEGER NEQ, IWM, IRES, IERSL, IPAR - DOUBLE PRECISION Y, TN, YPRIME, SAVR, X, EWT, WM, CJ, EPLIN, - 1 SQRTN, RSQRTN, RHOK, RPAR - DIMENSION Y(*), YPRIME(*), SAVR(*), X(*), EWT(*), - 1 WM(*), IWM(*), RPAR(*), IPAR(*) -C - INTEGER IFLAG, IRST, NRSTS, NRMAX, LR, LDL, LHES, LGMR, LQ, LV, - 1 LWK, LZ, MAXLP1, NPSL - INTEGER NLI, NPS, NCFL, NRE, MAXL, KMP, MITER - EXTERNAL RES, PSOL -C - PARAMETER (LNRE=12, LNCFL=16, LNLI=20, LNPS=21) - PARAMETER (LLOCWP=29, LLCIWP=30) - PARAMETER (LMITER=23, LMAXL=24, LKMP=25, LNRMAX=26) -C -C----------------------------------------------------------------------- -C IRST is set to 1, to indicate restarting is in effect. -C NRMAX is the maximum number of restarts. -C----------------------------------------------------------------------- - DATA IRST/1/ -C - LIWP = IWM(LLCIWP) - NLI = IWM(LNLI) - NPS = IWM(LNPS) - NCFL = IWM(LNCFL) - NRE = IWM(LNRE) - LWP = IWM(LLOCWP) - MAXL = IWM(LMAXL) - KMP = IWM(LKMP) - NRMAX = IWM(LNRMAX) - MITER = IWM(LMITER) - IERSL = 0 - IRES = 0 -C----------------------------------------------------------------------- -C Use a restarting strategy to solve the linear system -C P*X = -F. Parse the work vector, and perform initializations. -C Note that zero is the initial guess for X. -C----------------------------------------------------------------------- - MAXLP1 = MAXL + 1 - LV = 1 - LR = LV + NEQ*MAXL - LHES = LR + NEQ + 1 - LQ = LHES + MAXL*MAXLP1 - LWK = LQ + 2*MAXL - LDL = LWK + MIN0(1,MAXL-KMP)*NEQ - LZ = LDL + NEQ - CALL DSCAL (NEQ, RSQRTN, EWT, 1) - CALL DCOPY (NEQ, X, 1, WM(LR), 1) - DO 110 I = 1,NEQ - 110 X(I) = 0.D0 -C----------------------------------------------------------------------- -C Top of loop for the restart algorithm. Initial pass approximates -C X and sets up a transformed system to perform subsequent restarts -C to update X. NRSTS is initialized to -1, because restarting -C does not occur until after the first pass. -C Update NRSTS; conditionally copy DL to R; call the DSPIGM -C algorithm to solve A*Z = R; updated counters; update X with -C the residual solution. -C Note: if convergence is not achieved after NRMAX restarts, -C then the linear solver is considered to have failed. -C----------------------------------------------------------------------- - NRSTS = -1 - 115 CONTINUE - NRSTS = NRSTS + 1 - IF (NRSTS .GT. 0) CALL DCOPY (NEQ, WM(LDL), 1, WM(LR),1) - CALL DSPIGM (NEQ, TN, Y, YPRIME, SAVR, WM(LR), EWT, MAXL, MAXLP1, - 1 KMP, EPLIN, CJ, RES, IRES, NRES, PSOL, NPSL, WM(LZ), WM(LV), - 2 WM(LHES), WM(LQ), LGMR, WM(LWP), IWM(LIWP), WM(LWK), - 3 WM(LDL), RHOK, IFLAG, IRST, NRSTS, RPAR, IPAR) - NLI = NLI + LGMR - NPS = NPS + NPSL - NRE = NRE + NRES - DO 120 I = 1,NEQ - 120 X(I) = X(I) + WM(LZ+I-1) - IF ((IFLAG .EQ. 1) .AND. (NRSTS .LT. NRMAX) .AND. (IRES .EQ. 0)) - 1 GO TO 115 -C----------------------------------------------------------------------- -C The restart scheme is finished. Test IRES and IFLAG to see if -C convergence was not achieved, and set flags accordingly. -C----------------------------------------------------------------------- - IF (IRES .LT. 0) THEN - NCFL = NCFL + 1 - ELSE IF (IFLAG .NE. 0) THEN - NCFL = NCFL + 1 - IF (IFLAG .GT. 0) IERSL = 1 - IF (IFLAG .LT. 0) IERSL = -1 - ENDIF -C----------------------------------------------------------------------- -C Update IWM with counters, rescale EWT, and return. -C----------------------------------------------------------------------- - IWM(LNLI) = NLI - IWM(LNPS) = NPS - IWM(LNCFL) = NCFL - IWM(LNRE) = NRE - CALL DSCAL (NEQ, SQRTN, EWT, 1) - RETURN -C -C------END OF SUBROUTINE DSLVK------------------------------------------ - END - SUBROUTINE DSPIGM (NEQ, TN, Y, YPRIME, SAVR, R, WGHT, MAXL, - * MAXLP1, KMP, EPLIN, CJ, RES, IRES, NRE, PSOL, NPSL, Z, V, - * HES, Q, LGMR, WP, IWP, WK, DL, RHOK, IFLAG, IRST, NRSTS, - * RPAR, IPAR) -C -C***BEGIN PROLOGUE DSPIGM -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C***REVISION DATE 940927 Removed MNEWT and added RHOK in call list. -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine solves the linear system A * Z = R using a scaled -C preconditioned version of the generalized minimum residual method. -C An initial guess of Z = 0 is assumed. -C -C On entry -C -C NEQ = Problem size, passed to PSOL. -C -C TN = Current Value of T. -C -C Y = Array Containing current dependent variable vector. -C -C YPRIME = Array Containing current first derivative of Y. -C -C SAVR = Array containing current value of G(T,Y,YPRIME). -C -C R = The right hand side of the system A*Z = R. -C R is also used as work space when computing -C the final approximation and will therefore be -C destroyed. -C (R is the same as V(*,MAXL+1) in the call to DSPIGM.) -C -C WGHT = The vector of length NEQ containing the nonzero -C elements of the diagonal scaling matrix. -C -C MAXL = The maximum allowable order of the matrix H. -C -C MAXLP1 = MAXL + 1, used for dynamic dimensioning of HES. -C -C KMP = The number of previous vectors the new vector, VNEW, -C must be made orthogonal to. (KMP .LE. MAXL.) -C -C EPLIN = Tolerance on residuals R-A*Z in weighted rms norm. -C -C CJ = Scalar proportional to current value of -C 1/(step size H). -C -C WK = Real work array used by routine DATV and PSOL. -C -C DL = Real work array used for calculation of the residual -C norm RHO when the method is incomplete (KMP.LT.MAXL) -C and/or when using restarting. -C -C WP = Real work array used by preconditioner PSOL. -C -C IWP = Integer work array used by preconditioner PSOL. -C -C IRST = Method flag indicating if restarting is being -C performed. IRST .GT. 0 means restarting is active, -C while IRST = 0 means restarting is not being used. -C -C NRSTS = Counter for the number of restarts on the current -C call to DSPIGM. If NRSTS .GT. 0, then the residual -C R is already scaled, and so scaling of R is not -C necessary. -C -C -C On Return -C -C Z = The final computed approximation to the solution -C of the system A*Z = R. -C -C LGMR = The number of iterations performed and -C the current order of the upper Hessenberg -C matrix HES. -C -C NRE = The number of calls to RES (i.e. DATV) -C -C NPSL = The number of calls to PSOL. -C -C V = The neq by (LGMR+1) array containing the LGMR -C orthogonal vectors V(*,1) to V(*,LGMR). -C -C HES = The upper triangular factor of the QR decomposition -C of the (LGMR+1) by LGMR upper Hessenberg matrix whose -C entries are the scaled inner-products of A*V(*,I) -C and V(*,K). -C -C Q = Real array of length 2*MAXL containing the components -C of the givens rotations used in the QR decomposition -C of HES. It is loaded in DHEQR and used in DHELS. -C -C IRES = Error flag from RES. -C -C DL = Scaled preconditioned residual, -C (D-inverse)*(P-inverse)*(R-A*Z). Only loaded when -C performing restarts of the Krylov iteration. -C -C RHOK = Weighted norm of final preconditioned residual. -C -C IFLAG = Integer error flag.. -C 0 Means convergence in LGMR iterations, LGMR.LE.MAXL. -C 1 Means the convergence test did not pass in MAXL -C iterations, but the new residual norm (RHO) is -C .LT. the old residual norm (RNRM), and so Z is -C computed. -C 2 Means the convergence test did not pass in MAXL -C iterations, new residual norm (RHO) .GE. old residual -C norm (RNRM), and the initial guess, Z = 0, is -C returned. -C 3 Means there was a recoverable error in PSOL -C caused by the preconditioner being out of date. -C -1 Means there was an unrecoverable error in PSOL. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C PSOL, DNRM2, DSCAL, DATV, DORTH, DHEQR, DCOPY, DHELS, DAXPY -C -C***END PROLOGUE DSPIGM -C - INTEGER NEQ,MAXL,MAXLP1,KMP,IRES,NRE,NPSL,LGMR,IWP, - 1 IFLAG,IRST,NRSTS,IPAR - DOUBLE PRECISION TN,Y,YPRIME,SAVR,R,WGHT,EPLIN,CJ,Z,V,HES,Q,WP,WK, - 1 DL,RHOK,RPAR - DIMENSION Y(*), YPRIME(*), SAVR(*), R(*), WGHT(*), Z(*), - 1 V(NEQ,*), HES(MAXLP1,*), Q(*), WP(*), IWP(*), WK(*), DL(*), - 2 RPAR(*), IPAR(*) - INTEGER I, IER, INFO, IP1, I2, J, K, LL, LLP1 - DOUBLE PRECISION RNRM,C,DLNRM,PROD,RHO,S,SNORMW,DNRM2,TEM - EXTERNAL RES, PSOL -C - IER = 0 - IFLAG = 0 - LGMR = 0 - NPSL = 0 - NRE = 0 -C----------------------------------------------------------------------- -C The initial guess for Z is 0. The initial residual is therefore -C the vector R. Initialize Z to 0. -C----------------------------------------------------------------------- - DO 10 I = 1,NEQ - 10 Z(I) = 0.0D0 -C----------------------------------------------------------------------- -C Apply inverse of left preconditioner to vector R if NRSTS .EQ. 0. -C Form V(*,1), the scaled preconditioned right hand side. -C----------------------------------------------------------------------- - IF (NRSTS .EQ. 0) THEN - CALL PSOL (NEQ, TN, Y, YPRIME, SAVR, WK, CJ, WGHT, WP, IWP, - 1 R, EPLIN, IER, RPAR, IPAR) - NPSL = 1 - IF (IER .NE. 0) GO TO 300 - DO 30 I = 1,NEQ - 30 V(I,1) = R(I)*WGHT(I) - ELSE - DO 35 I = 1,NEQ - 35 V(I,1) = R(I) - ENDIF -C----------------------------------------------------------------------- -C Calculate norm of scaled vector V(*,1) and normalize it -C If, however, the norm of V(*,1) (i.e. the norm of the preconditioned -C residual) is .le. EPLIN, then return with Z=0. -C----------------------------------------------------------------------- - RNRM = DNRM2 (NEQ, V, 1) - IF (RNRM .LE. EPLIN) THEN - RHOK = RNRM - RETURN - ENDIF - TEM = 1.0D0/RNRM - CALL DSCAL (NEQ, TEM, V(1,1), 1) -C----------------------------------------------------------------------- -C Zero out the HES array. -C----------------------------------------------------------------------- - DO 65 J = 1,MAXL - DO 60 I = 1,MAXLP1 - 60 HES(I,J) = 0.0D0 - 65 CONTINUE -C----------------------------------------------------------------------- -C Main loop to compute the vectors V(*,2) to V(*,MAXL). -C The running product PROD is needed for the convergence test. -C----------------------------------------------------------------------- - PROD = 1.0D0 - DO 90 LL = 1,MAXL - LGMR = LL -C----------------------------------------------------------------------- -C Call routine DATV to compute VNEW = ABAR*V(LL), where ABAR is -C the matrix A with scaling and inverse preconditioner factors applied. -C Call routine DORTH to orthogonalize the new vector VNEW = V(*,LL+1). -C call routine DHEQR to update the factors of HES. -C----------------------------------------------------------------------- - CALL DATV (NEQ, Y, TN, YPRIME, SAVR, V(1,LL), WGHT, Z, - 1 RES, IRES, PSOL, V(1,LL+1), WK, WP, IWP, CJ, EPLIN, - 1 IER, NRE, NPSL, RPAR, IPAR) - IF (IRES .LT. 0) RETURN - IF (IER .NE. 0) GO TO 300 - CALL DORTH (V(1,LL+1), V, HES, NEQ, LL, MAXLP1, KMP, SNORMW) - HES(LL+1,LL) = SNORMW - CALL DHEQR (HES, MAXLP1, LL, Q, INFO, LL) - IF (INFO .EQ. LL) GO TO 120 -C----------------------------------------------------------------------- -C Update RHO, the estimate of the norm of the residual R - A*ZL. -C If KMP .LT. MAXL, then the vectors V(*,1),...,V(*,LL+1) are not -C necessarily orthogonal for LL .GT. KMP. The vector DL must then -C be computed, and its norm used in the calculation of RHO. -C----------------------------------------------------------------------- - PROD = PROD*Q(2*LL) - RHO = ABS(PROD*RNRM) - IF ((LL.GT.KMP) .AND. (KMP.LT.MAXL)) THEN - IF (LL .EQ. KMP+1) THEN - CALL DCOPY (NEQ, V(1,1), 1, DL, 1) - DO 75 I = 1,KMP - IP1 = I + 1 - I2 = I*2 - S = Q(I2) - C = Q(I2-1) - DO 70 K = 1,NEQ - 70 DL(K) = S*DL(K) + C*V(K,IP1) - 75 CONTINUE - ENDIF - S = Q(2*LL) - C = Q(2*LL-1)/SNORMW - LLP1 = LL + 1 - DO 80 K = 1,NEQ - 80 DL(K) = S*DL(K) + C*V(K,LLP1) - DLNRM = DNRM2 (NEQ, DL, 1) - RHO = RHO*DLNRM - ENDIF -C----------------------------------------------------------------------- -C Test for convergence. If passed, compute approximation ZL. -C If failed and LL .LT. MAXL, then continue iterating. -C----------------------------------------------------------------------- - IF (RHO .LE. EPLIN) GO TO 200 - IF (LL .EQ. MAXL) GO TO 100 -C----------------------------------------------------------------------- -C Rescale so that the norm of V(1,LL+1) is one. -C----------------------------------------------------------------------- - TEM = 1.0D0/SNORMW - CALL DSCAL (NEQ, TEM, V(1,LL+1), 1) - 90 CONTINUE - 100 CONTINUE - IF (RHO .LT. RNRM) GO TO 150 - 120 CONTINUE - IFLAG = 2 - DO 130 I = 1,NEQ - 130 Z(I) = 0.D0 - RETURN - 150 IFLAG = 1 -C----------------------------------------------------------------------- -C The tolerance was not met, but the residual norm was reduced. -C If performing restarting (IRST .gt. 0) calculate the residual vector -C RL and store it in the DL array. If the incomplete version is -C being used (KMP .lt. MAXL) then DL has already been calculated. -C----------------------------------------------------------------------- - IF (IRST .GT. 0) THEN - IF (KMP .EQ. MAXL) THEN -C -C Calculate DL from the V(I)'s. -C - CALL DCOPY (NEQ, V(1,1), 1, DL, 1) - MAXLM1 = MAXL - 1 - DO 175 I = 1,MAXLM1 - IP1 = I + 1 - I2 = I*2 - S = Q(I2) - C = Q(I2-1) - DO 170 K = 1,NEQ - 170 DL(K) = S*DL(K) + C*V(K,IP1) - 175 CONTINUE - S = Q(2*MAXL) - C = Q(2*MAXL-1)/SNORMW - DO 180 K = 1,NEQ - 180 DL(K) = S*DL(K) + C*V(K,MAXLP1) - ENDIF -C -C Scale DL by RNRM*PROD to obtain the residual RL. -C - TEM = RNRM*PROD - CALL DSCAL(NEQ, TEM, DL, 1) - ENDIF -C----------------------------------------------------------------------- -C Compute the approximation ZL to the solution. -C Since the vector Z was used as work space, and the initial guess -C of the Newton correction is zero, Z must be reset to zero. -C----------------------------------------------------------------------- - 200 CONTINUE - LL = LGMR - LLP1 = LL + 1 - DO 210 K = 1,LLP1 - 210 R(K) = 0.0D0 - R(1) = RNRM - CALL DHELS (HES, MAXLP1, LL, Q, R) - DO 220 K = 1,NEQ - 220 Z(K) = 0.0D0 - DO 230 I = 1,LL - CALL DAXPY (NEQ, R(I), V(1,I), 1, Z, 1) - 230 CONTINUE - DO 240 I = 1,NEQ - 240 Z(I) = Z(I)/WGHT(I) -C Load RHO into RHOK. - RHOK = RHO - RETURN -C----------------------------------------------------------------------- -C This block handles error returns forced by routine PSOL. -C----------------------------------------------------------------------- - 300 CONTINUE - IF (IER .LT. 0) IFLAG = -1 - IF (IER .GT. 0) IFLAG = 3 -C - RETURN -C -C------END OF SUBROUTINE DSPIGM----------------------------------------- - END - SUBROUTINE DATV (NEQ, Y, TN, YPRIME, SAVR, V, WGHT, YPTEM, RES, - * IRES, PSOL, Z, VTEM, WP, IWP, CJ, EPLIN, IER, NRE, NPSL, - * RPAR,IPAR) -C -C***BEGIN PROLOGUE DATV -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine computes the product -C -C Z = (D-inverse)*(P-inverse)*(dF/dY)*(D*V), -C -C where F(Y) = G(T, Y, CJ*(Y-A)), CJ is a scalar proportional to 1/H, -C and A involves the past history of Y. The quantity CJ*(Y-A) is -C an approximation to the first derivative of Y and is stored -C in the array YPRIME. Note that dF/dY = dG/dY + CJ*dG/dYPRIME. -C -C D is a diagonal scaling matrix, and P is the left preconditioning -C matrix. V is assumed to have L2 norm equal to 1. -C The product is stored in Z and is computed by means of a -C difference quotient, a call to RES, and one call to PSOL. -C -C On entry -C -C NEQ = Problem size, passed to RES and PSOL. -C -C Y = Array containing current dependent variable vector. -C -C YPRIME = Array containing current first derivative of y. -C -C SAVR = Array containing current value of G(T,Y,YPRIME). -C -C V = Real array of length NEQ (can be the same array as Z). -C -C WGHT = Array of length NEQ containing scale factors. -C 1/WGHT(I) are the diagonal elements of the matrix D. -C -C YPTEM = Work array of length NEQ. -C -C VTEM = Work array of length NEQ used to store the -C unscaled version of V. -C -C WP = Real work array used by preconditioner PSOL. -C -C IWP = Integer work array used by preconditioner PSOL. -C -C CJ = Scalar proportional to current value of -C 1/(step size H). -C -C -C On return -C -C Z = Array of length NEQ containing desired scaled -C matrix-vector product. -C -C IRES = Error flag from RES. -C -C IER = Error flag from PSOL. -C -C NRE = The number of calls to RES. -C -C NPSL = The number of calls to PSOL. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C RES, PSOL -C -C***END PROLOGUE DATV -C - INTEGER NEQ, IRES, IWP, IER, NRE, NPSL, IPAR - DOUBLE PRECISION Y, TN, YPRIME, SAVR, V, WGHT, YPTEM, Z, VTEM, - 1 WP, CJ, RPAR - DIMENSION Y(*), YPRIME(*), SAVR(*), V(*), WGHT(*), YPTEM(*), - 1 Z(*), VTEM(*), WP(*), IWP(*), RPAR(*), IPAR(*) - INTEGER I - DOUBLE PRECISION EPLIN - EXTERNAL RES, PSOL -C - IRES = 0 -C----------------------------------------------------------------------- -C Set VTEM = D * V. -C----------------------------------------------------------------------- - DO 10 I = 1,NEQ - 10 VTEM(I) = V(I)/WGHT(I) - IER = 0 -C----------------------------------------------------------------------- -C Store Y in Z and increment Z by VTEM. -C Store YPRIME in YPTEM and increment YPTEM by VTEM*CJ. -C----------------------------------------------------------------------- - DO 20 I = 1,NEQ - YPTEM(I) = YPRIME(I) + VTEM(I)*CJ - 20 Z(I) = Y(I) + VTEM(I) -C----------------------------------------------------------------------- -C Call RES with incremented Y, YPRIME arguments -C stored in Z, YPTEM. VTEM is overwritten with new residual. -C----------------------------------------------------------------------- - CONTINUE - CALL RES(TN,Z,YPTEM,CJ,VTEM,IRES,RPAR,IPAR) - NRE = NRE + 1 - IF (IRES .LT. 0) RETURN -C----------------------------------------------------------------------- -C Set Z = (dF/dY) * VBAR using difference quotient. -C (VBAR is old value of VTEM before calling RES) -C----------------------------------------------------------------------- - DO 70 I = 1,NEQ - 70 Z(I) = VTEM(I) - SAVR(I) -C----------------------------------------------------------------------- -C Apply inverse of left preconditioner to Z. -C----------------------------------------------------------------------- - CALL PSOL (NEQ, TN, Y, YPRIME, SAVR, YPTEM, CJ, WGHT, WP, IWP, - 1 Z, EPLIN, IER, RPAR, IPAR) - NPSL = NPSL + 1 - IF (IER .NE. 0) RETURN -C----------------------------------------------------------------------- -C Apply D-inverse to Z and return. -C----------------------------------------------------------------------- - DO 90 I = 1,NEQ - 90 Z(I) = Z(I)*WGHT(I) - RETURN -C -C------END OF SUBROUTINE DATV------------------------------------------- - END - SUBROUTINE DORTH (VNEW, V, HES, N, LL, LDHES, KMP, SNORMW) -C -C***BEGIN PROLOGUE DORTH -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine orthogonalizes the vector VNEW against the previous -C KMP vectors in the V array. It uses a modified Gram-Schmidt -C orthogonalization procedure with conditional reorthogonalization. -C -C On entry -C -C VNEW = The vector of length N containing a scaled product -C OF The Jacobian and the vector V(*,LL). -C -C V = The N x LL array containing the previous LL -C orthogonal vectors V(*,1) to V(*,LL). -C -C HES = An LL x LL upper Hessenberg matrix containing, -C in HES(I,K), K.LT.LL, scaled inner products of -C A*V(*,K) and V(*,I). -C -C LDHES = The leading dimension of the HES array. -C -C N = The order of the matrix A, and the length of VNEW. -C -C LL = The current order of the matrix HES. -C -C KMP = The number of previous vectors the new vector VNEW -C must be made orthogonal to (KMP .LE. MAXL). -C -C -C On return -C -C VNEW = The new vector orthogonal to V(*,I0), -C where I0 = MAX(1, LL-KMP+1). -C -C HES = Upper Hessenberg matrix with column LL filled in with -C scaled inner products of A*V(*,LL) and V(*,I). -C -C SNORMW = L-2 norm of VNEW. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DDOT, DNRM2, DAXPY -C -C***END PROLOGUE DORTH -C - INTEGER N, LL, LDHES, KMP - DOUBLE PRECISION VNEW, V, HES, SNORMW - DIMENSION VNEW(*), V(N,*), HES(LDHES,*) - INTEGER I, I0 - DOUBLE PRECISION ARG, DDOT, DNRM2, SUMDSQ, TEM, VNRM -C -C----------------------------------------------------------------------- -C Get norm of unaltered VNEW for later use. -C----------------------------------------------------------------------- - VNRM = DNRM2 (N, VNEW, 1) -C----------------------------------------------------------------------- -C Do Modified Gram-Schmidt on VNEW = A*V(LL). -C Scaled inner products give new column of HES. -C Projections of earlier vectors are subtracted from VNEW. -C----------------------------------------------------------------------- - I0 = MAX0(1,LL-KMP+1) - DO 10 I = I0,LL - HES(I,LL) = DDOT (N, V(1,I), 1, VNEW, 1) - TEM = -HES(I,LL) - CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) - 10 CONTINUE -C----------------------------------------------------------------------- -C Compute SNORMW = norm of VNEW. -C If VNEW is small compared to its input value (in norm), then -C Reorthogonalize VNEW to V(*,1) through V(*,LL). -C Correct if relative correction exceeds 1000*(unit roundoff). -C Finally, correct SNORMW using the dot products involved. -C----------------------------------------------------------------------- - SNORMW = DNRM2 (N, VNEW, 1) - IF (VNRM + 0.001D0*SNORMW .NE. VNRM) RETURN - SUMDSQ = 0.0D0 - DO 30 I = I0,LL - TEM = -DDOT (N, V(1,I), 1, VNEW, 1) - IF (HES(I,LL) + 0.001D0*TEM .EQ. HES(I,LL)) GO TO 30 - HES(I,LL) = HES(I,LL) - TEM - CALL DAXPY (N, TEM, V(1,I), 1, VNEW, 1) - SUMDSQ = SUMDSQ + TEM**2 - 30 CONTINUE - IF (SUMDSQ .EQ. 0.0D0) RETURN - ARG = MAX(0.0D0,SNORMW**2 - SUMDSQ) - SNORMW = SQRT(ARG) - RETURN -C -C------END OF SUBROUTINE DORTH------------------------------------------ - END - SUBROUTINE DHEQR (A, LDA, N, Q, INFO, IJOB) -C -C***BEGIN PROLOGUE DHEQR -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This routine performs a QR decomposition of an upper -C Hessenberg matrix A. There are two options available: -C -C (1) performing a fresh decomposition -C (2) updating the QR factors by adding a row and A -C column to the matrix A. -C -C DHEQR decomposes an upper Hessenberg matrix by using Givens -C rotations. -C -C On entry -C -C A DOUBLE PRECISION(LDA, N) -C The matrix to be decomposed. -C -C LDA INTEGER -C The leading dimension of the array A. -C -C N INTEGER -C A is an (N+1) by N Hessenberg matrix. -C -C IJOB INTEGER -C = 1 Means that a fresh decomposition of the -C matrix A is desired. -C .GE. 2 Means that the current decomposition of A -C will be updated by the addition of a row -C and a column. -C On return -C -C A The upper triangular matrix R. -C The factorization can be written Q*A = R, where -C Q is a product of Givens rotations and R is upper -C triangular. -C -C Q DOUBLE PRECISION(2*N) -C The factors C and S of each Givens rotation used -C in decomposing A. -C -C INFO INTEGER -C = 0 normal value. -C = K If A(K,K) .EQ. 0.0. This is not an error -C condition for this subroutine, but it does -C indicate that DHELS will divide by zero -C if called. -C -C Modification of LINPACK. -C Peter Brown, Lawrence Livermore Natl. Lab. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED (NONE) -C -C***END PROLOGUE DHEQR -C - INTEGER LDA, N, INFO, IJOB - DOUBLE PRECISION A(LDA,*), Q(*) - INTEGER I, IQ, J, K, KM1, KP1, NM1 - DOUBLE PRECISION C, S, T, T1, T2 -C - IF (IJOB .GT. 1) GO TO 70 -C----------------------------------------------------------------------- -C A new factorization is desired. -C----------------------------------------------------------------------- -C -C QR decomposition without pivoting. -C - INFO = 0 - DO 60 K = 1, N - KM1 = K - 1 - KP1 = K + 1 -C -C Compute Kth column of R. -C First, multiply the Kth column of A by the previous -C K-1 Givens rotations. -C - IF (KM1 .LT. 1) GO TO 20 - DO 10 J = 1, KM1 - I = 2*(J-1) + 1 - T1 = A(J,K) - T2 = A(J+1,K) - C = Q(I) - S = Q(I+1) - A(J,K) = C*T1 - S*T2 - A(J+1,K) = S*T1 + C*T2 - 10 CONTINUE -C -C Compute Givens components C and S. -C - 20 CONTINUE - IQ = 2*KM1 + 1 - T1 = A(K,K) - T2 = A(KP1,K) - IF (T2 .NE. 0.0D0) GO TO 30 - C = 1.0D0 - S = 0.0D0 - GO TO 50 - 30 CONTINUE - IF (ABS(T2) .LT. ABS(T1)) GO TO 40 - T = T1/T2 - S = -1.0D0/SQRT(1.0D0+T*T) - C = -S*T - GO TO 50 - 40 CONTINUE - T = T2/T1 - C = 1.0D0/SQRT(1.0D0+T*T) - S = -C*T - 50 CONTINUE - Q(IQ) = C - Q(IQ+1) = S - A(K,K) = C*T1 - S*T2 - IF (A(K,K) .EQ. 0.0D0) INFO = K - 60 CONTINUE - RETURN -C----------------------------------------------------------------------- -C The old factorization of A will be updated. A row and a column -C has been added to the matrix A. -C N by N-1 is now the old size of the matrix. -C----------------------------------------------------------------------- - 70 CONTINUE - NM1 = N - 1 -C----------------------------------------------------------------------- -C Multiply the new column by the N previous Givens rotations. -C----------------------------------------------------------------------- - DO 100 K = 1,NM1 - I = 2*(K-1) + 1 - T1 = A(K,N) - T2 = A(K+1,N) - C = Q(I) - S = Q(I+1) - A(K,N) = C*T1 - S*T2 - A(K+1,N) = S*T1 + C*T2 - 100 CONTINUE -C----------------------------------------------------------------------- -C Complete update of decomposition by forming last Givens rotation, -C and multiplying it times the column vector (A(N,N),A(NP1,N)). -C----------------------------------------------------------------------- - INFO = 0 - T1 = A(N,N) - T2 = A(N+1,N) - IF (T2 .NE. 0.0D0) GO TO 110 - C = 1.0D0 - S = 0.0D0 - GO TO 130 - 110 CONTINUE - IF (ABS(T2) .LT. ABS(T1)) GO TO 120 - T = T1/T2 - S = -1.0D0/SQRT(1.0D0+T*T) - C = -S*T - GO TO 130 - 120 CONTINUE - T = T2/T1 - C = 1.0D0/SQRT(1.0D0+T*T) - S = -C*T - 130 CONTINUE - IQ = 2*N - 1 - Q(IQ) = C - Q(IQ+1) = S - A(N,N) = C*T1 - S*T2 - IF (A(N,N) .EQ. 0.0D0) INFO = N - RETURN -C -C------END OF SUBROUTINE DHEQR------------------------------------------ - END - SUBROUTINE DHELS (A, LDA, N, Q, B) -C -C***BEGIN PROLOGUE DHELS -C***DATE WRITTEN 890101 (YYMMDD) -C***REVISION DATE 900926 (YYMMDD) -C -C -C----------------------------------------------------------------------- -C***DESCRIPTION -C -C This is similar to the LINPACK routine DGESL except that -C A is an upper Hessenberg matrix. -C -C DHELS solves the least squares problem -C -C MIN (B-A*X,B-A*X) -C -C using the factors computed by DHEQR. -C -C On entry -C -C A DOUBLE PRECISION (LDA, N) -C The output from DHEQR which contains the upper -C triangular factor R in the QR decomposition of A. -C -C LDA INTEGER -C The leading dimension of the array A . -C -C N INTEGER -C A is originally an (N+1) by N matrix. -C -C Q DOUBLE PRECISION(2*N) -C The coefficients of the N givens rotations -C used in the QR factorization of A. -C -C B DOUBLE PRECISION(N+1) -C The right hand side vector. -C -C -C On return -C -C B The solution vector X. -C -C -C Modification of LINPACK. -C Peter Brown, Lawrence Livermore Natl. Lab. -C -C----------------------------------------------------------------------- -C***ROUTINES CALLED -C DAXPY -C -C***END PROLOGUE DHELS -C - INTEGER LDA, N - DOUBLE PRECISION A(LDA,*), B(*), Q(*) - INTEGER IQ, K, KB, KP1 - DOUBLE PRECISION C, S, T, T1, T2 -C -C Minimize (B-A*X,B-A*X). -C First form Q*B. -C - DO 20 K = 1, N - KP1 = K + 1 - IQ = 2*(K-1) + 1 - C = Q(IQ) - S = Q(IQ+1) - T1 = B(K) - T2 = B(KP1) - B(K) = C*T1 - S*T2 - B(KP1) = S*T1 + C*T2 - 20 CONTINUE -C -C Now solve R*X = Q*B. -C - DO 40 KB = 1, N - K = N + 1 - KB - B(K) = B(K)/A(K,K) - T = -B(K) - CALL DAXPY (K-1, T, A(1,K), 1, B(1), 1) - 40 CONTINUE - RETURN -C -C------END OF SUBROUTINE DHELS------------------------------------------ - END diff --git a/ext/math/dgbfa.f b/ext/math/dgbfa.f deleted file mode 100644 index c26e6f579..000000000 --- a/ext/math/dgbfa.f +++ /dev/null @@ -1,174 +0,0 @@ - subroutine dgbfa(abd,lda,n,ml,mu,ipvt,info) - integer lda,n,ml,mu,ipvt(1),info - double precision abd(lda,1) -c -c dgbfa factors a double precision band matrix by elimination. -c -c dgbfa is usually called by dgbco, but it can be called -c directly with a saving in time if rcond is not needed. -c -c on entry -c -c abd double precision(lda, n) -c contains the matrix in band storage. the columns -c of the matrix are stored in the columns of abd and -c the diagonals of the matrix are stored in rows -c ml+1 through 2*ml+mu+1 of abd . -c see the comments below for details. -c -c lda integer -c the leading dimension of the array abd . -c lda must be .ge. 2*ml + mu + 1 . -c -c n integer -c the order of the original matrix. -c -c ml integer -c number of diagonals below the main diagonal. -c 0 .le. ml .lt. n . -c -c mu integer -c number of diagonals above the main diagonal. -c 0 .le. mu .lt. n . -c more efficient if ml .le. mu . -c on return -c -c abd an upper triangular matrix in band storage and -c the multipliers which were used to obtain it. -c the factorization can be written a = l*u where -c l is a product of permutation and unit lower -c triangular matrices and u is upper triangular. -c -c ipvt integer(n) -c an integer vector of pivot indices. -c -c info integer -c = 0 normal value. -c = k if u(k,k) .eq. 0.0 . this is not an error -c condition for this subroutine, but it does -c indicate that dgbsl will divide by zero if -c called. use rcond in dgbco for a reliable -c indication of singularity. -c -c band storage -c -c if a is a band matrix, the following program segment -c will set up the input. -c -c ml = (band width below the diagonal) -c mu = (band width above the diagonal) -c m = ml + mu + 1 -c do 20 j = 1, n -c i1 = max0(1, j-mu) -c i2 = min0(n, j+ml) -c do 10 i = i1, i2 -c k = i - j + m -c abd(k,j) = a(i,j) -c 10 continue -c 20 continue -c -c this uses rows ml+1 through 2*ml+mu+1 of abd . -c in addition, the first ml rows in abd are used for -c elements generated during the triangularization. -c the total number of rows needed in abd is 2*ml+mu+1 . -c the ml+mu by ml+mu upper left triangle and the -c ml by ml lower right triangle are not referenced. -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas daxpy,dscal,idamax -c fortran max0,min0 -c -c internal variables -c - double precision t - integer i,idamax,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1 -c -c - m = ml + mu + 1 - info = 0 -c -c zero initial fill-in columns -c - j0 = mu + 2 - j1 = min0(n,m) - 1 - if (j1 .lt. j0) go to 30 - do 20 jz = j0, j1 - i0 = m + 1 - jz - do 10 i = i0, ml - abd(i,jz) = 0.0d0 - 10 continue - 20 continue - 30 continue - jz = j1 - ju = 0 -c -c gaussian elimination with partial pivoting -c - nm1 = n - 1 - if (nm1 .lt. 1) go to 130 - do 120 k = 1, nm1 - kp1 = k + 1 -c -c zero next fill-in column -c - jz = jz + 1 - if (jz .gt. n) go to 50 - if (ml .lt. 1) go to 50 - do 40 i = 1, ml - abd(i,jz) = 0.0d0 - 40 continue - 50 continue -c -c find l = pivot index -c - lm = min0(ml,n-k) - l = idamax(lm+1,abd(m,k),1) + m - 1 - ipvt(k) = l + k - m -c -c zero pivot implies this column already triangularized -c - if (abd(l,k) .eq. 0.0d0) go to 100 -c -c interchange if necessary -c - if (l .eq. m) go to 60 - t = abd(l,k) - abd(l,k) = abd(m,k) - abd(m,k) = t - 60 continue -c -c compute multipliers -c - t = -1.0d0/abd(m,k) - call dscal(lm,t,abd(m+1,k),1) -c -c row elimination with column indexing -c - ju = min0(max0(ju,mu+ipvt(k)),n) - mm = m - if (ju .lt. kp1) go to 90 - do 80 j = kp1, ju - l = l - 1 - mm = mm - 1 - t = abd(l,j) - if (l .eq. mm) go to 70 - abd(l,j) = abd(mm,j) - abd(mm,j) = t - 70 continue - call daxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1) - 80 continue - 90 continue - go to 110 - 100 continue - info = k - 110 continue - 120 continue - 130 continue - ipvt(n) = n - if (abd(m,n) .eq. 0.0d0) info = n - return - end diff --git a/ext/math/dgbsl.f b/ext/math/dgbsl.f deleted file mode 100644 index 1b1b6ed54..000000000 --- a/ext/math/dgbsl.f +++ /dev/null @@ -1,135 +0,0 @@ - subroutine dgbsl(abd,lda,n,ml,mu,ipvt,b,job) - integer lda,n,ml,mu,ipvt(1),job - double precision abd(lda,1),b(1) -c -c dgbsl solves the double precision band system -c a * x = b or trans(a) * x = b -c using the factors computed by dgbco or dgbfa. -c -c on entry -c -c abd double precision(lda, n) -c the output from dgbco or dgbfa. -c -c lda integer -c the leading dimension of the array abd . -c -c n integer -c the order of the original matrix. -c -c ml integer -c number of diagonals below the main diagonal. -c -c mu integer -c number of diagonals above the main diagonal. -c -c ipvt integer(n) -c the pivot vector from dgbco or dgbfa. -c -c b double precision(n) -c the right hand side vector. -c -c job integer -c = 0 to solve a*x = b , -c = nonzero to solve trans(a)*x = b , where -c trans(a) is the transpose. -c -c on return -c -c b the solution vector x . -c -c error condition -c -c a division by zero will occur if the input factor contains a -c zero on the diagonal. technically this indicates singularity -c but it is often caused by improper arguments or improper -c setting of lda . it will not occur if the subroutines are -c called correctly and if dgbco has set rcond .gt. 0.0 -c or dgbfa has set info .eq. 0 . -c -c to compute inverse(a) * c where c is a matrix -c with p columns -c call dgbco(abd,lda,n,ml,mu,ipvt,rcond,z) -c if (rcond is too small) go to ... -c do 10 j = 1, p -c call dgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0) -c 10 continue -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas daxpy,ddot -c fortran min0 -c -c internal variables -c - double precision ddot,t - integer k,kb,l,la,lb,lm,m,nm1 -c - m = mu + ml + 1 - nm1 = n - 1 - if (job .ne. 0) go to 50 -c -c job = 0 , solve a * x = b -c first solve l*y = b -c - if (ml .eq. 0) go to 30 - if (nm1 .lt. 1) go to 30 - do 20 k = 1, nm1 - lm = min0(ml,n-k) - l = ipvt(k) - t = b(l) - if (l .eq. k) go to 10 - b(l) = b(k) - b(k) = t - 10 continue - call daxpy(lm,t,abd(m+1,k),1,b(k+1),1) - 20 continue - 30 continue -c -c now solve u*x = y -c - do 40 kb = 1, n - k = n + 1 - kb - b(k) = b(k)/abd(m,k) - lm = min0(k,m) - 1 - la = m - lm - lb = k - lm - t = -b(k) - call daxpy(lm,t,abd(la,k),1,b(lb),1) - 40 continue - go to 100 - 50 continue -c -c job = nonzero, solve trans(a) * x = b -c first solve trans(u)*y = b -c - do 60 k = 1, n - lm = min0(k,m) - 1 - la = m - lm - lb = k - lm - t = ddot(lm,abd(la,k),1,b(lb),1) - b(k) = (b(k) - t)/abd(m,k) - 60 continue -c -c now solve trans(l)*x = y -c - if (ml .eq. 0) go to 90 - if (nm1 .lt. 1) go to 90 - do 80 kb = 1, nm1 - k = n - kb - lm = min0(ml,n-k) - b(k) = b(k) + ddot(lm,abd(m+1,k),1,b(k+1),1) - l = ipvt(k) - if (l .eq. k) go to 70 - t = b(l) - b(l) = b(k) - b(k) = t - 70 continue - 80 continue - 90 continue - 100 continue - return - end diff --git a/ext/math/dgefa.f b/ext/math/dgefa.f deleted file mode 100644 index 14f266a9c..000000000 --- a/ext/math/dgefa.f +++ /dev/null @@ -1,104 +0,0 @@ - - subroutine dgefa(a,lda,n,ipvt,info) - integer lda,n,ipvt(1),info - double precision a(lda,1) -c -c dgefa factors a double precision matrix by gaussian elimination. -c -c dgefa is usually called by dgeco, but it can be called -c directly with a saving in time if rcond is not needed. -c (time for dgeco) = (1 + 9/n)*(time for dgefa) . -c -c on entry -c -c a double precision(lda, n) -c the matrix to be factored. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c on return -c -c a an upper triangular matrix and the multipliers -c which were used to obtain it. -c the factorization can be written a = l*u where -c l is a product of permutation and unit lower -c triangular matrices and u is upper triangular. -c -c ipvt integer(n) -c an integer vector of pivot indices. -c -c info integer -c = 0 normal value. -c = k if u(k,k) .eq. 0.0 . this is not an error -c condition for this subroutine, but it does -c indicate that dgesl or dgedi will divide by zero -c if called. use rcond in dgeco for a reliable -c indication of singularity. -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas daxpy,dscal,idamax -c -c internal variables -c - double precision t - integer idamax,j,k,kp1,l,nm1 -c -c -c gaussian elimination with partial pivoting -c - info = 0 - nm1 = n - 1 - if (nm1 .lt. 1) go to 70 - do 60 k = 1, nm1 - kp1 = k + 1 -c -c find l = pivot index -c - l = idamax(n-k+1,a(k,k),1) + k - 1 - ipvt(k) = l -c -c zero pivot implies this column already triangularized -c - if (a(l,k) .eq. 0.0d0) go to 40 -c -c interchange if necessary -c - if (l .eq. k) go to 10 - t = a(l,k) - a(l,k) = a(k,k) - a(k,k) = t - 10 continue -c -c compute multipliers -c - t = -1.0d0/a(k,k) - call dscal(n-k,t,a(k+1,k),1) -c -c row elimination with column indexing -c - do 30 j = kp1, n - t = a(l,j) - if (l .eq. k) go to 20 - a(l,j) = a(k,j) - a(k,j) = t - 20 continue - call daxpy(n-k,t,a(k+1,k),1,a(k+1,j),1) - 30 continue - go to 50 - 40 continue - info = k - 50 continue - 60 continue - 70 continue - ipvt(n) = n - if (a(n,n) .eq. 0.0d0) info = n - return - end diff --git a/ext/math/dgesl.f b/ext/math/dgesl.f deleted file mode 100644 index 093fa5182..000000000 --- a/ext/math/dgesl.f +++ /dev/null @@ -1,117 +0,0 @@ - subroutine dgesl(a,lda,n,ipvt,b,job) - integer lda,n,ipvt(1),job - double precision a(lda,1),b(1) -c -c dgesl solves the double precision system -c a * x = b or trans(a) * x = b -c using the factors computed by dgeco or dgefa. -c -c on entry -c -c a double precision(lda, n) -c the output from dgeco or dgefa. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c ipvt integer(n) -c the pivot vector from dgeco or dgefa. -c -c b double precision(n) -c the right hand side vector. -c -c job integer -c = 0 to solve a*x = b , -c = nonzero to solve trans(a)*x = b where -c trans(a) is the transpose. -c -c on return -c -c b the solution vector x . -c -c error condition -c -c a division by zero will occur if the input factor contains a -c zero on the diagonal. technically this indicates singularity -c but it is often caused by improper arguments or improper -c setting of lda . it will not occur if the subroutines are -c called correctly and if dgeco has set rcond .gt. 0.0 -c or dgefa has set info .eq. 0 . -c -c to compute inverse(a) * c where c is a matrix -c with p columns -c call dgeco(a,lda,n,ipvt,rcond,z) -c if (rcond is too small) go to ... -c do 10 j = 1, p -c call dgesl(a,lda,n,ipvt,c(1,j),0) -c 10 continue -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas daxpy,ddot -c -c internal variables -c - double precision ddot,t - integer k,kb,l,nm1 -c - nm1 = n - 1 - if (job .ne. 0) go to 50 -c -c job = 0 , solve a * x = b -c first solve l*y = b -c - if (nm1 .lt. 1) go to 30 - do 20 k = 1, nm1 - l = ipvt(k) - t = b(l) - if (l .eq. k) go to 10 - b(l) = b(k) - b(k) = t - 10 continue - call daxpy(n-k,t,a(k+1,k),1,b(k+1),1) - 20 continue - 30 continue -c -c now solve u*x = y -c - do 40 kb = 1, n - k = n + 1 - kb - b(k) = b(k)/a(k,k) - t = -b(k) - call daxpy(k-1,t,a(1,k),1,b(1),1) - 40 continue - go to 100 - 50 continue -c -c job = nonzero, solve trans(a) * x = b -c first solve trans(u)*y = b -c - do 60 k = 1, n - t = ddot(k-1,a(1,k),1,b(1),1) - b(k) = (b(k) - t)/a(k,k) - 60 continue -c -c now solve trans(l)*x = y -c - if (nm1 .lt. 1) go to 90 - do 80 kb = 1, nm1 - k = n - kb - b(k) = b(k) + ddot(n-k,a(k+1,k),1,b(k+1),1) - l = ipvt(k) - if (l .eq. k) go to 70 - t = b(l) - b(l) = b(k) - b(k) = t - 70 continue - 80 continue - 90 continue - 100 continue - return - end diff --git a/ext/math/dp1vlu.f b/ext/math/dp1vlu.f deleted file mode 100644 index 1af92d209..000000000 --- a/ext/math/dp1vlu.f +++ /dev/null @@ -1,151 +0,0 @@ -*DECK DP1VLU - SUBROUTINE DP1VLU (L, NDER, X, YFIT, YP, A) -C***BEGIN PROLOGUE DP1VLU -C***PURPOSE Use the coefficients generated by DPOLFT to evaluate the -C polynomial fit of degree L, along with the first NDER of -C its derivatives, at a specified point. -C***LIBRARY SLATEC -C***CATEGORY K6 -C***TYPE DOUBLE PRECISION (PVALUE-S, DP1VLU-D) -C***KEYWORDS CURVE FITTING, LEAST SQUARES, POLYNOMIAL APPROXIMATION -C***AUTHOR Shampine, L. F., (SNLA) -C Davenport, S. M., (SNLA) -C***DESCRIPTION -C -C Abstract -C -C The subroutine DP1VLU uses the coefficients generated by DPOLFT -C to evaluate the polynomial fit of degree L , along with the first -C NDER of its derivatives, at a specified point. Computationally -C stable recurrence relations are used to perform this task. -C -C The parameters for DP1VLU are -C -C Input -- ALL TYPE REAL variables are DOUBLE PRECISION -C L - the degree of polynomial to be evaluated. L may be -C any non-negative integer which is less than or equal -C to NDEG , the highest degree polynomial provided -C by DPOLFT . -C NDER - the number of derivatives to be evaluated. NDER -C may be 0 or any positive value. If NDER is less -C than 0, it will be treated as 0. -C X - the argument at which the polynomial and its -C derivatives are to be evaluated. -C A - work and output array containing values from last -C call to DPOLFT . -C -C Output -- ALL TYPE REAL variables are DOUBLE PRECISION -C YFIT - value of the fitting polynomial of degree L at X -C YP - array containing the first through NDER derivatives -C of the polynomial of degree L . YP must be -C dimensioned at least NDER in the calling program. -C -C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, -C Curve fitting by polynomials in one variable, Report -C SLA-74-0270, Sandia Laboratories, June 1974. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 740601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890911 Removed unnecessary intrinsics. (WRB) -C 891006 Cosmetic changes to prologue. (WRB) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DP1VLU - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - INTEGER I,IC,ILO,IN,INP1,IUP,K1,K1I,K2,K3,K3P1,K3PN,K4,K4P1,K4PN, - * KC,L,LM1,LP1,MAXORD,N,NDER,NDO,NDP1,NORD - DOUBLE PRECISION A(*),CC,DIF,VAL,X,YFIT,YP(*) - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT DP1VLU - IF (L .LT. 0) GO TO 12 - NDO = MAX(NDER,0) - NDO = MIN(NDO,L) - MAXORD = A(1) + 0.5D0 - K1 = MAXORD + 1 - K2 = K1 + MAXORD - K3 = K2 + MAXORD + 2 - NORD = A(K3) + 0.5D0 - IF (L .GT. NORD) GO TO 11 - K4 = K3 + L + 1 - IF (NDER .LT. 1) GO TO 2 - DO 1 I = 1,NDER - 1 YP(I) = 0.0D0 - 2 IF (L .GE. 2) GO TO 4 - IF (L .EQ. 1) GO TO 3 -C -C L IS 0 -C - VAL = A(K2+1) - GO TO 10 -C -C L IS 1 -C - 3 CC = A(K2+2) - VAL = A(K2+1) + (X-A(2))*CC - IF (NDER .GE. 1) YP(1) = CC - GO TO 10 -C -C L IS GREATER THAN 1 -C - 4 NDP1 = NDO + 1 - K3P1 = K3 + 1 - K4P1 = K4 + 1 - LP1 = L + 1 - LM1 = L - 1 - ILO = K3 + 3 - IUP = K4 + NDP1 - DO 5 I = ILO,IUP - 5 A(I) = 0.0D0 - DIF = X - A(LP1) - KC = K2 + LP1 - A(K4P1) = A(KC) - A(K3P1) = A(KC-1) + DIF*A(K4P1) - A(K3+2) = A(K4P1) -C -C EVALUATE RECURRENCE RELATIONS FOR FUNCTION VALUE AND DERIVATIVES -C - DO 9 I = 1,LM1 - IN = L - I - INP1 = IN + 1 - K1I = K1 + INP1 - IC = K2 + IN - DIF = X - A(INP1) - VAL = A(IC) + DIF*A(K3P1) - A(K1I)*A(K4P1) - IF (NDO .LE. 0) GO TO 8 - DO 6 N = 1,NDO - K3PN = K3P1 + N - K4PN = K4P1 + N - 6 YP(N) = DIF*A(K3PN) + N*A(K3PN-1) - A(K1I)*A(K4PN) -C -C SAVE VALUES NEEDED FOR NEXT EVALUATION OF RECURRENCE RELATIONS -C - DO 7 N = 1,NDO - K3PN = K3P1 + N - K4PN = K4P1 + N - A(K4PN) = A(K3PN) - 7 A(K3PN) = YP(N) - 8 A(K4P1) = A(K3P1) - 9 A(K3P1) = VAL -C -C NORMAL RETURN OR ABORT DUE TO ERROR -C - 10 YFIT = VAL - RETURN -C - 11 WRITE (XERN1, '(I8)') L - WRITE (XERN2, '(I8)') NORD - CALL XERMSG ('SLATEC', 'DP1VLU', - * 'THE ORDER OF POLYNOMIAL EVALUATION, L = ' // XERN1 // - * ' REQUESTED EXCEEDS THE HIGHEST ORDER FIT, NORD = ' // XERN2 // - * ', COMPUTED BY DPOLFT -- EXECUTION TERMINATED.', 8, 2) - RETURN -C - 12 CALL XERMSG ('SLATEC', 'DP1VLU', - + 'INVALID INPUT PARAMETER. ORDER OF POLYNOMIAL EVALUATION ' // - + 'REQUESTED IS NEGATIVE.', 2, 2) - RETURN - END diff --git a/ext/math/dpcoef.f b/ext/math/dpcoef.f deleted file mode 100644 index 074a3426f..000000000 --- a/ext/math/dpcoef.f +++ /dev/null @@ -1,78 +0,0 @@ -*DECK DPCOEF - SUBROUTINE DPCOEF (L, C, TC, A) -C***BEGIN PROLOGUE DPCOEF -C***PURPOSE Convert the DPOLFT coefficients to Taylor series form. -C***LIBRARY SLATEC -C***CATEGORY K1A1A2 -C***TYPE DOUBLE PRECISION (PCOEF-S, DPCOEF-D) -C***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT -C***AUTHOR Shampine, L. F., (SNLA) -C Davenport, S. M., (SNLA) -C***DESCRIPTION -C -C Abstract -C -C DPOLFT computes the least squares polynomial fit of degree L as -C a sum of orthogonal polynomials. DPCOEF changes this fit to its -C Taylor expansion about any point C , i.e. writes the polynomial -C as a sum of powers of (X-C). Taking C=0. gives the polynomial -C in powers of X, but a suitable non-zero C often leads to -C polynomials which are better scaled and more accurately evaluated. -C -C The parameters for DPCOEF are -C -C INPUT -- All TYPE REAL variables are DOUBLE PRECISION -C L - Indicates the degree of polynomial to be changed to -C its Taylor expansion. To obtain the Taylor -C coefficients in reverse order, input L as the -C negative of the degree desired. The absolute value -C of L must be less than or equal to NDEG, the highest -C degree polynomial fitted by DPOLFT . -C C - The point about which the Taylor expansion is to be -C made. -C A - Work and output array containing values from last -C call to DPOLFT . -C -C OUTPUT -- All TYPE REAL variables are DOUBLE PRECISION -C TC - Vector containing the first LL+1 Taylor coefficients -C where LL=ABS(L). If L.GT.0 , the coefficients are -C in the usual Taylor series order, i.e. -C P(X) = TC(1) + TC(2)*(X-C) + ... + TC(N+1)*(X-C)**N -C If L .LT. 0, the coefficients are in reverse order, -C i.e. -C P(X) = TC(1)*(X-C)**N + ... + TC(N)*(X-C) + TC(N+1) -C -C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, -C Curve fitting by polynomials in one variable, Report -C SLA-74-0270, Sandia Laboratories, June 1974. -C***ROUTINES CALLED DP1VLU -C***REVISION HISTORY (YYMMDD) -C 740601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891006 Cosmetic changes to prologue. (WRB) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE DPCOEF -C - INTEGER I,L,LL,LLP1,LLP2,NEW,NR - DOUBLE PRECISION A(*),C,FAC,SAVE,TC(*) -C***FIRST EXECUTABLE STATEMENT DPCOEF - LL = ABS(L) - LLP1 = LL + 1 - CALL DP1VLU (LL,LL,C,TC(1),TC(2),A) - IF (LL .LT. 2) GO TO 2 - FAC = 1.0D0 - DO 1 I = 3,LLP1 - FAC = FAC*(I-1) - 1 TC(I) = TC(I)/FAC - 2 IF (L .GE. 0) GO TO 4 - NR = LLP1/2 - LLP2 = LL + 2 - DO 3 I = 1,NR - SAVE = TC(I) - NEW = LLP2 - I - TC(I) = TC(NEW) - 3 TC(NEW) = SAVE - 4 RETURN - END diff --git a/ext/math/dpolft.f b/ext/math/dpolft.f deleted file mode 100644 index bbebb3dbd..000000000 --- a/ext/math/dpolft.f +++ /dev/null @@ -1,364 +0,0 @@ -*DECK DPOLFT - SUBROUTINE DPOLFT (N, X, Y, W, MAXDEG, NDEG, EPS, R, IERR, A) -C***BEGIN PROLOGUE DPOLFT -C***PURPOSE Fit discrete data in a least squares sense by polynomials -C in one variable. -C***LIBRARY SLATEC -C***CATEGORY K1A1A2 -C***TYPE DOUBLE PRECISION (POLFIT-S, DPOLFT-D) -C***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT -C***AUTHOR Shampine, L. F., (SNLA) -C Davenport, S. M., (SNLA) -C Huddleston, R. E., (SNLL) -C***DESCRIPTION -C -C Abstract -C -C Given a collection of points X(I) and a set of values Y(I) which -C correspond to some function or measurement at each of the X(I), -C subroutine DPOLFT computes the weighted least-squares polynomial -C fits of all degrees up to some degree either specified by the user -C or determined by the routine. The fits thus obtained are in -C orthogonal polynomial form. Subroutine DP1VLU may then be -C called to evaluate the fitted polynomials and any of their -C derivatives at any point. The subroutine DPCOEF may be used to -C express the polynomial fits as powers of (X-C) for any specified -C point C. -C -C The parameters for DPOLFT are -C -C Input -- All TYPE REAL variables are DOUBLE PRECISION -C N - the number of data points. The arrays X, Y and W -C must be dimensioned at least N (N .GE. 1). -C X - array of values of the independent variable. These -C values may appear in any order and need not all be -C distinct. -C Y - array of corresponding function values. -C W - array of positive values to be used as weights. If -C W(1) is negative, DPOLFT will set all the weights -C to 1.0, which means unweighted least squares error -C will be minimized. To minimize relative error, the -C user should set the weights to: W(I) = 1.0/Y(I)**2, -C I = 1,...,N . -C MAXDEG - maximum degree to be allowed for polynomial fit. -C MAXDEG may be any non-negative integer less than N. -C Note -- MAXDEG cannot be equal to N-1 when a -C statistical test is to be used for degree selection, -C i.e., when input value of EPS is negative. -C EPS - specifies the criterion to be used in determining -C the degree of fit to be computed. -C (1) If EPS is input negative, DPOLFT chooses the -C degree based on a statistical F test of -C significance. One of three possible -C significance levels will be used: .01, .05 or -C .10. If EPS=-1.0 , the routine will -C automatically select one of these levels based -C on the number of data points and the maximum -C degree to be considered. If EPS is input as -C -.01, -.05, or -.10, a significance level of -C .01, .05, or .10, respectively, will be used. -C (2) If EPS is set to 0., DPOLFT computes the -C polynomials of degrees 0 through MAXDEG . -C (3) If EPS is input positive, EPS is the RMS -C error tolerance which must be satisfied by the -C fitted polynomial. DPOLFT will increase the -C degree of fit until this criterion is met or -C until the maximum degree is reached. -C -C Output -- All TYPE REAL variables are DOUBLE PRECISION -C NDEG - degree of the highest degree fit computed. -C EPS - RMS error of the polynomial of degree NDEG . -C R - vector of dimension at least NDEG containing values -C of the fit of degree NDEG at each of the X(I) . -C Except when the statistical test is used, these -C values are more accurate than results from subroutine -C DP1VLU normally are. -C IERR - error flag with the following possible values. -C 1 -- indicates normal execution, i.e., either -C (1) the input value of EPS was negative, and the -C computed polynomial fit of degree NDEG -C satisfies the specified F test, or -C (2) the input value of EPS was 0., and the fits of -C all degrees up to MAXDEG are complete, or -C (3) the input value of EPS was positive, and the -C polynomial of degree NDEG satisfies the RMS -C error requirement. -C 2 -- invalid input parameter. At least one of the input -C parameters has an illegal value and must be corrected -C before DPOLFT can proceed. Valid input results -C when the following restrictions are observed -C N .GE. 1 -C 0 .LE. MAXDEG .LE. N-1 for EPS .GE. 0. -C 0 .LE. MAXDEG .LE. N-2 for EPS .LT. 0. -C W(1)=-1.0 or W(I) .GT. 0., I=1,...,N . -C 3 -- cannot satisfy the RMS error requirement with a -C polynomial of degree no greater than MAXDEG . Best -C fit found is of degree MAXDEG . -C 4 -- cannot satisfy the test for significance using -C current value of MAXDEG . Statistically, the -C best fit found is of order NORD . (In this case, -C NDEG will have one of the values: MAXDEG-2, -C MAXDEG-1, or MAXDEG). Using a higher value of -C MAXDEG may result in passing the test. -C A - work and output array having at least 3N+3MAXDEG+3 -C locations -C -C Note - DPOLFT calculates all fits of degrees up to and including -C NDEG . Any or all of these fits can be evaluated or -C expressed as powers of (X-C) using DP1VLU and DPCOEF -C after just one call to DPOLFT . -C -C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, -C Curve fitting by polynomials in one variable, Report -C SLA-74-0270, Sandia Laboratories, June 1974. -C***ROUTINES CALLED DP1VLU, XERMSG -C***REVISION HISTORY (YYMMDD) -C 740601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 891006 Cosmetic changes to prologue. (WRB) -C 891006 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900911 Added variable YP to DOUBLE PRECISION declaration. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920527 Corrected erroneous statements in DESCRIPTION. (WRB) -C***END PROLOGUE DPOLFT - INTEGER I,IDEGF,IERR,J,JP1,JPAS,K1,K1PJ,K2,K2PJ,K3,K3PI,K4, - * K4PI,K5,K5PI,KSIG,M,MAXDEG,MOP1,NDEG,NDER,NFAIL - DOUBLE PRECISION TEMD1,TEMD2 - DOUBLE PRECISION A(*),DEGF,DEN,EPS,ETST,F,FCRIT,R(*),SIG,SIGJ, - * SIGJM1,SIGPAS,TEMP,X(*),XM,Y(*),YP,W(*),W1,W11 - DOUBLE PRECISION CO(4,3) -c SAVE CO -c DATA CO(1,1), CO(2,1), CO(3,1), CO(4,1), CO(1,2), CO(2,2), -c 1 CO(3,2), CO(4,2), CO(1,3), CO(2,3), CO(3,3), -c 2 CO(4,3)/-13.086850D0,-2.4648165D0,-3.3846535D0,-1.2973162D0, -c 3 -3.3381146D0,-1.7812271D0,-3.2578406D0,-1.6589279D0, -c 4 -1.6282703D0,-1.3152745D0,-3.2640179D0,-1.9829776D0/ -C***FIRST EXECUTABLE STATEMENT DPOLFT - -c write(*,*) 'DPOLFT n = ',n -c do ii = 1,n -c write(*,*) x(ii), y(ii), w(ii) -c end do -c write(*,*) ' maxdeg, eps = ',maxdeg,eps - - M = ABS(N) - IF (M .EQ. 0) GO TO 30 - IF (MAXDEG .LT. 0) GO TO 30 - A(1) = MAXDEG - MOP1 = MAXDEG + 1 - IF (M .LT. MOP1) GO TO 30 - IF (EPS .LT. 0.0D0 .AND. M .EQ. MOP1) GO TO 30 - XM = M - ETST = EPS*EPS*XM - IF (W(1) .LT. 0.0D0) GO TO 2 - DO 1 I = 1,M - IF (W(I) .LE. 0.0D0) GO TO 30 - 1 CONTINUE - GO TO 4 - 2 DO 3 I = 1,M - 3 W(I) = 1.0D0 - 4 IF (EPS .GE. 0.0D0) GO TO 8 -C -C DETERMINE SIGNIFICANCE LEVEL INDEX TO BE USED IN STATISTICAL TEST FOR -C CHOOSING DEGREE OF POLYNOMIAL FIT -C - IF (EPS .GT. (-.55D0)) GO TO 5 - IDEGF = M - MAXDEG - 1 - KSIG = 1 - IF (IDEGF .LT. 10) KSIG = 2 - IF (IDEGF .LT. 5) KSIG = 3 - GO TO 8 - 5 KSIG = 1 - IF (EPS .LT. (-.03D0)) KSIG = 2 - IF (EPS .LT. (-.07D0)) KSIG = 3 -C -C INITIALIZE INDEXES AND COEFFICIENTS FOR FITTING -C - 8 K1 = MAXDEG + 1 - K2 = K1 + MAXDEG - K3 = K2 + MAXDEG + 2 - K4 = K3 + M - K5 = K4 + M - DO 9 I = 2,K4 - 9 A(I) = 0.0D0 - W11 = 0.0D0 - IF (N .LT. 0) GO TO 11 -C -C UNCONSTRAINED CASE -C - DO 10 I = 1,M - K4PI = K4 + I - A(K4PI) = 1.0D0 - 10 W11 = W11 + W(I) - GO TO 13 -C -C CONSTRAINED CASE -C - 11 DO 12 I = 1,M - K4PI = K4 + I - 12 W11 = W11 + W(I)*A(K4PI)**2 -C -C COMPUTE FIT OF DEGREE ZERO -C - 13 TEMD1 = 0.0D0 - DO 14 I = 1,M - K4PI = K4 + I - TEMD1 = TEMD1 + W(I)*Y(I)*A(K4PI) - 14 CONTINUE - TEMD1 = TEMD1/W11 - A(K2+1) = TEMD1 - SIGJ = 0.0D0 - DO 15 I = 1,M - K4PI = K4 + I - K5PI = K5 + I - TEMD2 = TEMD1*A(K4PI) - R(I) = TEMD2 - A(K5PI) = TEMD2 - R(I) - 15 SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2 - J = 0 -C -C SEE IF POLYNOMIAL OF DEGREE 0 SATISFIES THE DEGREE SELECTION CRITERION -C - IF (EPS) 24,26,27 -C -C INCREMENT DEGREE -C - 16 J = J + 1 - JP1 = J + 1 - K1PJ = K1 + J - K2PJ = K2 + J - SIGJM1 = SIGJ -C -C COMPUTE NEW B COEFFICIENT EXCEPT WHEN J = 1 -C - IF (J .GT. 1) A(K1PJ) = W11/W1 -C -C COMPUTE NEW A COEFFICIENT -C - TEMD1 = 0.0D0 - DO 18 I = 1,M - K4PI = K4 + I - TEMD2 = A(K4PI) - TEMD1 = TEMD1 + X(I)*W(I)*TEMD2*TEMD2 - 18 CONTINUE - A(JP1) = TEMD1/W11 -C -C EVALUATE ORTHOGONAL POLYNOMIAL AT DATA POINTS -C - W1 = W11 - W11 = 0.0D0 - DO 19 I = 1,M - K3PI = K3 + I - K4PI = K4 + I - TEMP = A(K3PI) - A(K3PI) = A(K4PI) - A(K4PI) = (X(I)-A(JP1))*A(K3PI) - A(K1PJ)*TEMP - 19 W11 = W11 + W(I)*A(K4PI)**2 -C -C GET NEW ORTHOGONAL POLYNOMIAL COEFFICIENT USING PARTIAL DOUBLE -C PRECISION -C - TEMD1 = 0.0D0 - DO 20 I = 1,M - K4PI = K4 + I - K5PI = K5 + I - TEMD2 = W(I)*((Y(I)-R(I))-A(K5PI))*A(K4PI) - 20 TEMD1 = TEMD1 + TEMD2 - TEMD1 = TEMD1/W11 - A(K2PJ+1) = TEMD1 -C -C UPDATE POLYNOMIAL EVALUATIONS AT EACH OF THE DATA POINTS, AND -C ACCUMULATE SUM OF SQUARES OF ERRORS. THE POLYNOMIAL EVALUATIONS ARE -C COMPUTED AND STORED IN EXTENDED PRECISION. FOR THE I-TH DATA POINT, -C THE MOST SIGNIFICANT BITS ARE STORED IN R(I) , AND THE LEAST -C SIGNIFICANT BITS ARE IN A(K5PI) . -C - SIGJ = 0.0D0 - DO 21 I = 1,M - K4PI = K4 + I - K5PI = K5 + I - TEMD2 = R(I) + A(K5PI) + TEMD1*A(K4PI) - R(I) = TEMD2 - A(K5PI) = TEMD2 - R(I) - 21 SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2 -C -C SEE IF DEGREE SELECTION CRITERION HAS BEEN SATISFIED OR IF DEGREE -C MAXDEG HAS BEEN REACHED -C - IF (EPS) 23,26,27 -C -C COMPUTE F STATISTICS (INPUT EPS .LT. 0.) -C - 23 IF (SIGJ .EQ. 0.0D0) GO TO 29 - DEGF = M - J - 1 - DEN = (CO(4,KSIG)*DEGF + 1.0D0)*DEGF - FCRIT = (((CO(3,KSIG)*DEGF) + CO(2,KSIG))*DEGF + CO(1,KSIG))/DEN - FCRIT = FCRIT*FCRIT - F = (SIGJM1 - SIGJ)*DEGF/SIGJ - IF (F .LT. FCRIT) GO TO 25 -C -C POLYNOMIAL OF DEGREE J SATISFIES F TEST -C - 24 SIGPAS = SIGJ - JPAS = J - NFAIL = 0 - IF (MAXDEG .EQ. J) GO TO 32 - GO TO 16 -C -C POLYNOMIAL OF DEGREE J FAILS F TEST. IF THERE HAVE BEEN THREE -C SUCCESSIVE FAILURES, A STATISTICALLY BEST DEGREE HAS BEEN FOUND. -C - 25 NFAIL = NFAIL + 1 - IF (NFAIL .GE. 3) GO TO 29 - IF (MAXDEG .EQ. J) GO TO 32 - GO TO 16 -C -C RAISE THE DEGREE IF DEGREE MAXDEG HAS NOT YET BEEN REACHED (INPUT -C EPS = 0.) -C - 26 IF (MAXDEG .EQ. J) GO TO 28 - GO TO 16 -C -C SEE IF RMS ERROR CRITERION IS SATISFIED (INPUT EPS .GT. 0.) -C - 27 IF (SIGJ .LE. ETST) GO TO 28 - IF (MAXDEG .EQ. J) GO TO 31 - GO TO 16 -C -C RETURNS -C - 28 IERR = 1 - NDEG = J - SIG = SIGJ - GO TO 33 - 29 IERR = 1 - NDEG = JPAS - SIG = SIGPAS - GO TO 33 - 30 IERR = 2 - CALL XERMSG ('SLATEC', 'DPOLFT', 'INVALID INPUT PARAMETER.', 2, - + 1) - GO TO 37 - 31 IERR = 3 - NDEG = MAXDEG - SIG = SIGJ - GO TO 33 - 32 IERR = 4 - NDEG = JPAS - SIG = SIGPAS -C - 33 A(K3) = NDEG -C -C WHEN STATISTICAL TEST HAS BEEN USED, EVALUATE THE BEST POLYNOMIAL AT -C ALL THE DATA POINTS IF R DOES NOT ALREADY CONTAIN THESE VALUES -C - IF(EPS .GE. 0.0 .OR. NDEG .EQ. MAXDEG) GO TO 36 - NDER = 0 - DO 35 I = 1,M - CALL DP1VLU (NDEG,NDER,X(I),R(I),YP,A) - 35 CONTINUE - 36 EPS = SQRT(SIG/XM) - 37 RETURN - END diff --git a/ext/math/fdump.f b/ext/math/fdump.f deleted file mode 100644 index c649f252b..000000000 --- a/ext/math/fdump.f +++ /dev/null @@ -1,72 +0,0 @@ -*DECK FDUMP - SUBROUTINE FDUMP -C***BEGIN PROLOGUE FDUMP -C***PURPOSE Symbolic dump (should be locally written). -C***LIBRARY SLATEC (XERMSG) -C***CATEGORY R3 -C***TYPE ALL (FDUMP-A) -C***KEYWORDS ERROR, XERMSG -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C ***Note*** Machine Dependent Routine -C FDUMP is intended to be replaced by a locally written -C version which produces a symbolic dump. Failing this, -C it should be replaced by a version which prints the -C subprogram nesting list. Note that this dump must be -C printed on each of up to five files, as indicated by the -C XGETUA routine. See XSETUA and XGETUA for details. -C -C Written by Ron Jones, with SLATEC Common Math Library Subcommittee -C -C***REFERENCES (NONE) -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C***END PROLOGUE FDUMP -C***FIRST EXECUTABLE STATEMENT FDUMP - RETURN - END - -c$$$ -c$$$ integer function isamax(n,sx,incx) -c$$$c -c$$$c finds the index of element having max. absolute value. -c$$$c jack dongarra, linpack, 3/11/78. -c$$$c modified 3/93 to return if incx .le. 0. -c$$$c -c$$$ real sx(1),smax -c$$$ integer i,incx,ix,n -c$$$c -c$$$ isamax = 0 -c$$$ if( n.lt.1 .or. incx.le.0 ) return -c$$$ isamax = 1 -c$$$ if(n.eq.1)return -c$$$ if(incx.eq.1)go to 20 -c$$$c -c$$$c code for increment not equal to 1 -c$$$c -c$$$ ix = 1 -c$$$ smax = abs(sx(1)) -c$$$ ix = ix + incx -c$$$ do 10 i = 2,n -c$$$ if(abs(sx(ix)).le.smax) go to 5 -c$$$ isamax = i -c$$$ smax = abs(sx(ix)) -c$$$ 5 ix = ix + incx -c$$$ 10 continue -c$$$ return -c$$$c -c$$$c code for increment equal to 1 -c$$$c -c$$$ 20 smax = abs(sx(1)) -c$$$ do 30 i = 2,n -c$$$ if(abs(sx(i)).le.smax) go to 30 -c$$$ isamax = i -c$$$ smax = abs(sx(i)) -c$$$ 30 continue -c$$$ return -c$$$ end -c$$$ diff --git a/ext/math/j4save.f b/ext/math/j4save.f deleted file mode 100644 index 46b42a7b8..000000000 --- a/ext/math/j4save.f +++ /dev/null @@ -1,65 +0,0 @@ -*DECK J4SAVE - FUNCTION J4SAVE (IWHICH, IVALUE, ISET) -C***BEGIN PROLOGUE J4SAVE -C***SUBSIDIARY -C***PURPOSE Save or recall global variables needed by error -C handling routines. -C***LIBRARY SLATEC (XERROR) -C***TYPE INTEGER (J4SAVE-I) -C***KEYWORDS ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C J4SAVE saves and recalls several global variables needed -C by the library error handling routines. -C -C Description of Parameters -C --Input-- -C IWHICH - Index of item desired. -C = 1 Refers to current error number. -C = 2 Refers to current error control flag. -C = 3 Refers to current unit number to which error -C messages are to be sent. (0 means use standard.) -C = 4 Refers to the maximum number of times any -C message is to be printed (as set by XERMAX). -C = 5 Refers to the total number of units to which -C each error message is to be written. -C = 6 Refers to the 2nd unit for error messages -C = 7 Refers to the 3rd unit for error messages -C = 8 Refers to the 4th unit for error messages -C = 9 Refers to the 5th unit for error messages -C IVALUE - The value to be set for the IWHICH-th parameter, -C if ISET is .TRUE. . -C ISET - If ISET=.TRUE., the IWHICH-th parameter will BE -C given the value, IVALUE. If ISET=.FALSE., the -C IWHICH-th parameter will be unchanged, and IVALUE -C is a dummy parameter. -C --Output-- -C The (old) value of the IWHICH-th parameter will be returned -C in the function value, J4SAVE. -C -C***SEE ALSO XERMSG -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900205 Minor modifications to prologue. (WRB) -C 900402 Added TYPE section. (WRB) -C 910411 Added KEYWORDS section. (WRB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE J4SAVE - LOGICAL ISET - INTEGER IPARAM(9) -c SAVE IPARAM - DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/ - DATA IPARAM(5)/1/ - DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/ -C***FIRST EXECUTABLE STATEMENT J4SAVE - J4SAVE = IPARAM(IWHICH) - IF (ISET) IPARAM(IWHICH) = IVALUE - RETURN - END diff --git a/ext/math/mach.cpp b/ext/math/mach.cpp deleted file mode 100644 index de90e1c4b..000000000 --- a/ext/math/mach.cpp +++ /dev/null @@ -1,88 +0,0 @@ - -/* Standard C source for D1MACH -- remove the * in column 1 */ -#include -#include -#include -#include -#include - -extern "C" { - - double d1mach_(long* i) - { - switch (*i) { - case 1: - return DBL_MIN; - case 2: - return DBL_MAX; - case 3: - return DBL_EPSILON/FLT_RADIX; - case 4: - return DBL_EPSILON; - case 5: - return log10((double)FLT_RADIX); - } - fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i); - exit(1); - return 0; /* some compilers demand return values */ - } - - double d1mach(long* i) - { - return d1mach_(i); - } - - - long i1mach_(long* i) - { - switch (*i) { - case 1: - return 5; /* standard input */ - case 2: - return 6; /* standard output */ - case 3: - return 7; /* standard punch */ - case 4: - return 0; /* standard error */ - case 5: - return 32; /* bits per integer */ - case 6: - return sizeof(int); - case 7: - return 2; /* base for integers */ - case 8: - return 31; /* digits of integer base */ - case 9: - return LONG_MAX; - case 10: - return FLT_RADIX; - case 11: - return FLT_MANT_DIG; - case 12: - return FLT_MIN_EXP; - case 13: - return FLT_MAX_EXP; - case 14: - return DBL_MANT_DIG; - case 15: - return DBL_MIN_EXP; - case 16: - return DBL_MAX_EXP; - } - fprintf(stderr, "invalid argument: i1mach(%ld)\n", *i); - exit(1); - return 0; /* some compilers demand return values */ - } - - long i1mach(long* i) - { - return i1mach_(i); - } - - long _i1mach_(long* i) - { - return i1mach_(i); - } - -} - diff --git a/ext/math/pcoef.f b/ext/math/pcoef.f deleted file mode 100644 index 28fe548ff..000000000 --- a/ext/math/pcoef.f +++ /dev/null @@ -1,712 +0,0 @@ -*DECK PCOEF - SUBROUTINE PCOEF (L, C, TC, A) -C***BEGIN PROLOGUE PCOEF -C***PURPOSE Convert the POLFIT coefficients to Taylor series form. -C***LIBRARY SLATEC -C***CATEGORY K1A1A2 -C***TYPE SINGLE PRECISION (PCOEF-S, DPCOEF-D) -C***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT -C***AUTHOR Shampine, L. F., (SNLA) -C Davenport, S. M., (SNLA) -C***DESCRIPTION -C -C Written BY L. F. Shampine and S. M. Davenport. -C -C Abstract -C -C POLFIT computes the least squares polynomial fit of degree L as -C a sum of orthogonal polynomials. PCOEF changes this fit to its -C Taylor expansion about any point C , i.e. writes the polynomial -C as a sum of powers of (X-C). Taking C=0. gives the polynomial -C in powers of X, but a suitable non-zero C often leads to -C polynomials which are better scaled and more accurately evaluated. -C -C The parameters for PCOEF are -C -C INPUT -- -C L - Indicates the degree of polynomial to be changed to -C its Taylor expansion. To obtain the Taylor -C coefficients in reverse order, input L as the -C negative of the degree desired. The absolute value -C of L must be less than or equal to NDEG, the highest -C degree polynomial fitted by POLFIT . -C C - The point about which the Taylor expansion is to be -C made. -C A - Work and output array containing values from last -C call to POLFIT . -C -C OUTPUT -- -C TC - Vector containing the first LL+1 Taylor coefficients -C where LL=ABS(L). If L.GT.0 , the coefficients are -C in the usual Taylor series order, i.e. -C P(X) = TC(1) + TC(2)*(X-C) + ... + TC(N+1)*(X-C)**N -C If L .LT. 0, the coefficients are in reverse order, -C i.e. -C P(X) = TC(1)*(X-C)**N + ... + TC(N)*(X-C) + TC(N+1) -C -C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, -C Curve fitting by polynomials in one variable, Report -C SLA-74-0270, Sandia Laboratories, June 1974. -C***ROUTINES CALLED PVALUE -C***REVISION HISTORY (YYMMDD) -C 740601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE PCOEF -C - DIMENSION A(*), TC(*) -C***FIRST EXECUTABLE STATEMENT PCOEF - LL = ABS(L) - LLP1 = LL + 1 - CALL PVALUE (LL,LL,C,TC(1),TC(2),A) - IF (LL .LT. 2) GO TO 2 - FAC = 1.0 - DO 1 I = 3,LLP1 - FAC = FAC*(I-1) - 1 TC(I) = TC(I)/FAC - 2 IF (L .GE. 0) GO TO 4 - NR = LLP1/2 - LLP2 = LL + 2 - DO 3 I = 1,NR - SAVE = TC(I) - NEW = LLP2 - I - TC(I) = TC(NEW) - 3 TC(NEW) = SAVE - 4 RETURN - END -c$$$ -c$$$ subroutine dscal(n,da,dx,incx) -c$$$c -c$$$c scales a vector by a constant. -c$$$c uses unrolled loops for increment equal to one. -c$$$c jack dongarra, linpack, 3/11/78. -c$$$c modified 3/93 to return if incx .le. 0. -c$$$c -c$$$ double precision da,dx(1) -c$$$ integer i,incx,m,mp1,n,nincx -c$$$c -c$$$ if( n.le.0 .or. incx.le.0 )return -c$$$ if(incx.eq.1)go to 20 -c$$$c -c$$$c code for increment not equal to 1 -c$$$c -c$$$ nincx = n*incx -c$$$ do 10 i = 1,nincx,incx -c$$$ dx(i) = da*dx(i) -c$$$ 10 continue -c$$$ return -c$$$c -c$$$c code for increment equal to 1 -c$$$c -c$$$c -c$$$c clean-up loop -c$$$c -c$$$ 20 m = mod(n,5) -c$$$ if( m .eq. 0 ) go to 40 -c$$$ do 30 i = 1,m -c$$$ dx(i) = da*dx(i) -c$$$ 30 continue -c$$$ if( n .lt. 5 ) return -c$$$ 40 mp1 = m + 1 -c$$$ do 50 i = mp1,n,5 -c$$$ dx(i) = da*dx(i) -c$$$ dx(i + 1) = da*dx(i + 1) -c$$$ dx(i + 2) = da*dx(i + 2) -c$$$ dx(i + 3) = da*dx(i + 3) -c$$$ dx(i + 4) = da*dx(i + 4) -c$$$ 50 continue -c$$$ return -c$$$ end - - subroutine dgbco(abd,lda,n,ml,mu,ipvt,rcond,z) - integer lda,n,ml,mu,ipvt(1) - double precision abd(lda,1),z(1) - double precision rcond -c -c dgbco factors a double precision band matrix by gaussian -c elimination and estimates the condition of the matrix. -c -c if rcond is not needed, dgbfa is slightly faster. -c to solve a*x = b , follow dgbco by dgbsl. -c to compute inverse(a)*c , follow dgbco by dgbsl. -c to compute determinant(a) , follow dgbco by dgbdi. -c -c on entry -c -c abd double precision(lda, n) -c contains the matrix in band storage. the columns -c of the matrix are stored in the columns of abd and -c the diagonals of the matrix are stored in rows -c ml+1 through 2*ml+mu+1 of abd . -c see the comments below for details. -c -c lda integer -c the leading dimension of the array abd . -c lda must be .ge. 2*ml + mu + 1 . -c -c n integer -c the order of the original matrix. -c -c ml integer -c number of diagonals below the main diagonal. -c 0 .le. ml .lt. n . -c -c mu integer -c number of diagonals above the main diagonal. -c 0 .le. mu .lt. n . -c more efficient if ml .le. mu . -c -c on return -c -c abd an upper triangular matrix in band storage and -c the multipliers which were used to obtain it. -c the factorization can be written a = l*u where -c l is a product of permutation and unit lower -c triangular matrices and u is upper triangular. -c -c ipvt integer(n) -c an integer vector of pivot indices. -c -c rcond double precision -c an estimate of the reciprocal condition of a . -c for the system a*x = b , relative perturbations -c in a and b of size epsilon may cause -c relative perturbations in x of size epsilon/rcond . -c if rcond is so small that the logical expression -c 1.0 + rcond .eq. 1.0 -c is true, then a may be singular to working -c precision. in particular, rcond is zero if -c exact singularity is detected or the estimate -c underflows. -c -c z double precision(n) -c a work vector whose contents are usually unimportant. -c if a is close to a singular matrix, then z is -c an approximate null vector in the sense that -c norm(a*z) = rcond*norm(a)*norm(z) . -c -c band storage -c -c if a is a band matrix, the following program segment -c will set up the input. -c -c ml = (band width below the diagonal) -c mu = (band width above the diagonal) -c m = ml + mu + 1 -c do 20 j = 1, n -c i1 = max0(1, j-mu) -c i2 = min0(n, j+ml) -c do 10 i = i1, i2 -c k = i - j + m -c abd(k,j) = a(i,j) -c 10 continue -c 20 continue -c -c this uses rows ml+1 through 2*ml+mu+1 of abd . -c in addition, the first ml rows in abd are used for -c elements generated during the triangularization. -c the total number of rows needed in abd is 2*ml+mu+1 . -c the ml+mu by ml+mu upper left triangle and the -c ml by ml lower right triangle are not referenced. -c -c example.. if the original matrix is -c -c 11 12 13 0 0 0 -c 21 22 23 24 0 0 -c 0 32 33 34 35 0 -c 0 0 43 44 45 46 -c 0 0 0 54 55 56 -c 0 0 0 0 65 66 -c -c then n = 6, ml = 1, mu = 2, lda .ge. 5 and abd should contain -c -c * * * + + + , * = not used -c * * 13 24 35 46 , + = used for pivoting -c * 12 23 34 45 56 -c 11 22 33 44 55 66 -c 21 32 43 54 65 * -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c linpack dgbfa -c blas daxpy,ddot,dscal,dasum -c fortran dabs,dmax1,max0,min0,dsign -c -c internal variables -c - double precision ddot,ek,t,wk,wkm - double precision anorm,s,dasum,sm,ynorm - integer is,info,j,ju,k,kb,kp1,l,la,lm,lz,m,mm -c -c -c compute 1-norm of a -c - anorm = 0.0d0 - l = ml + 1 - is = l + mu - do 10 j = 1, n - anorm = dmax1(anorm,dasum(l,abd(is,j),1)) - if (is .gt. ml + 1) is = is - 1 - if (j .le. mu) l = l + 1 - if (j .ge. n - ml) l = l - 1 - 10 continue -c -c factor -c - call dgbfa(abd,lda,n,ml,mu,ipvt,info) -c -c rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) . -c estimate = norm(z)/norm(y) where a*z = y and trans(a)*y = e . -c trans(a) is the transpose of a . the components of e are -c chosen to cause maximum local growth in the elements of w where -c trans(u)*w = e . the vectors are frequently rescaled to avoid -c overflow. -c -c solve trans(u)*w = e -c - ek = 1.0d0 - do 20 j = 1, n - z(j) = 0.0d0 - 20 continue - m = ml + mu + 1 - ju = 0 - do 100 k = 1, n - if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k)) - if (dabs(ek-z(k)) .le. dabs(abd(m,k))) go to 30 - s = dabs(abd(m,k))/dabs(ek-z(k)) - call dscal(n,s,z,1) - ek = s*ek - 30 continue - wk = ek - z(k) - wkm = -ek - z(k) - s = dabs(wk) - sm = dabs(wkm) - if (abd(m,k) .eq. 0.0d0) go to 40 - wk = wk/abd(m,k) - wkm = wkm/abd(m,k) - go to 50 - 40 continue - wk = 1.0d0 - wkm = 1.0d0 - 50 continue - kp1 = k + 1 - ju = min0(max0(ju,mu+ipvt(k)),n) - mm = m - if (kp1 .gt. ju) go to 90 - do 60 j = kp1, ju - mm = mm - 1 - sm = sm + dabs(z(j)+wkm*abd(mm,j)) - z(j) = z(j) + wk*abd(mm,j) - s = s + dabs(z(j)) - 60 continue - if (s .ge. sm) go to 80 - t = wkm - wk - wk = wkm - mm = m - do 70 j = kp1, ju - mm = mm - 1 - z(j) = z(j) + t*abd(mm,j) - 70 continue - 80 continue - 90 continue - z(k) = wk - 100 continue - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) -c -c solve trans(l)*y = w -c - do 120 kb = 1, n - k = n + 1 - kb - lm = min0(ml,n-k) - if (k .lt. n) z(k) = z(k) + ddot(lm,abd(m+1,k),1,z(k+1),1) - if (dabs(z(k)) .le. 1.0d0) go to 110 - s = 1.0d0/dabs(z(k)) - call dscal(n,s,z,1) - 110 continue - l = ipvt(k) - t = z(l) - z(l) = z(k) - z(k) = t - 120 continue - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) -c - ynorm = 1.0d0 -c -c solve l*v = y -c - do 140 k = 1, n - l = ipvt(k) - t = z(l) - z(l) = z(k) - z(k) = t - lm = min0(ml,n-k) - if (k .lt. n) call daxpy(lm,t,abd(m+1,k),1,z(k+1),1) - if (dabs(z(k)) .le. 1.0d0) go to 130 - s = 1.0d0/dabs(z(k)) - call dscal(n,s,z,1) - ynorm = s*ynorm - 130 continue - 140 continue - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) - ynorm = s*ynorm -c -c solve u*z = w -c - do 160 kb = 1, n - k = n + 1 - kb - if (dabs(z(k)) .le. dabs(abd(m,k))) go to 150 - s = dabs(abd(m,k))/dabs(z(k)) - call dscal(n,s,z,1) - ynorm = s*ynorm - 150 continue - if (abd(m,k) .ne. 0.0d0) z(k) = z(k)/abd(m,k) - if (abd(m,k) .eq. 0.0d0) z(k) = 1.0d0 - lm = min0(k,m) - 1 - la = m - lm - lz = k - lm - t = -z(k) - call daxpy(lm,t,abd(la,k),1,z(lz),1) - 160 continue -c make znorm = 1.0 - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) - ynorm = s*ynorm -c - if (anorm .ne. 0.0d0) rcond = ynorm/anorm - if (anorm .eq. 0.0d0) rcond = 0.0d0 - return - end - - subroutine dgeco(a,lda,n,ipvt,rcond,z) - integer lda,n,ipvt(1) - double precision a(lda,1),z(1) - double precision rcond -c -c dgeco factors a double precision matrix by gaussian elimination -c and estimates the condition of the matrix. -c -c if rcond is not needed, dgefa is slightly faster. -c to solve a*x = b , follow dgeco by dgesl. -c to compute inverse(a)*c , follow dgeco by dgesl. -c to compute determinant(a) , follow dgeco by dgedi. -c to compute inverse(a) , follow dgeco by dgedi. -c -c on entry -c -c a double precision(lda, n) -c the matrix to be factored. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c on return -c -c a an upper triangular matrix and the multipliers -c which were used to obtain it. -c the factorization can be written a = l*u where -c l is a product of permutation and unit lower -c triangular matrices and u is upper triangular. -c -c ipvt integer(n) -c an integer vector of pivot indices. -c -c rcond double precision -c an estimate of the reciprocal condition of a . -c for the system a*x = b , relative perturbations -c in a and b of size epsilon may cause -c relative perturbations in x of size epsilon/rcond . -c if rcond is so small that the logical expression -c 1.0 + rcond .eq. 1.0 -c is true, then a may be singular to working -c precision. in particular, rcond is zero if -c exact singularity is detected or the estimate -c underflows. -c -c z double precision(n) -c a work vector whose contents are usually unimportant. -c if a is close to a singular matrix, then z is -c an approximate null vector in the sense that -c norm(a*z) = rcond*norm(a)*norm(z) . -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c linpack dgefa -c blas daxpy,ddot,dscal,dasum -c fortran dabs,dmax1,dsign -c -c internal variables -c - double precision ddot,ek,t,wk,wkm - double precision anorm,s,dasum,sm,ynorm - integer info,j,k,kb,kp1,l -c -c -c compute 1-norm of a -c - anorm = 0.0d0 - do 10 j = 1, n - anorm = dmax1(anorm,dasum(n,a(1,j),1)) - 10 continue -c -c factor -c - call dgefa(a,lda,n,ipvt,info) -c -c rcond = 1/(norm(a)*(estimate of norm(inverse(a)))) . -c estimate = norm(z)/norm(y) where a*z = y and trans(a)*y = e . -c trans(a) is the transpose of a . the components of e are -c chosen to cause maximum local growth in the elements of w where -c trans(u)*w = e . the vectors are frequently rescaled to avoid -c overflow. -c -c solve trans(u)*w = e -c - ek = 1.0d0 - do 20 j = 1, n - z(j) = 0.0d0 - 20 continue - do 100 k = 1, n - if (z(k) .ne. 0.0d0) ek = dsign(ek,-z(k)) - if (dabs(ek-z(k)) .le. dabs(a(k,k))) go to 30 - s = dabs(a(k,k))/dabs(ek-z(k)) - call dscal(n,s,z,1) - ek = s*ek - 30 continue - wk = ek - z(k) - wkm = -ek - z(k) - s = dabs(wk) - sm = dabs(wkm) - if (a(k,k) .eq. 0.0d0) go to 40 - wk = wk/a(k,k) - wkm = wkm/a(k,k) - go to 50 - 40 continue - wk = 1.0d0 - wkm = 1.0d0 - 50 continue - kp1 = k + 1 - if (kp1 .gt. n) go to 90 - do 60 j = kp1, n - sm = sm + dabs(z(j)+wkm*a(k,j)) - z(j) = z(j) + wk*a(k,j) - s = s + dabs(z(j)) - 60 continue - if (s .ge. sm) go to 80 - t = wkm - wk - wk = wkm - do 70 j = kp1, n - z(j) = z(j) + t*a(k,j) - 70 continue - 80 continue - 90 continue - z(k) = wk - 100 continue - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) -c -c solve trans(l)*y = w -c - do 120 kb = 1, n - k = n + 1 - kb - if (k .lt. n) z(k) = z(k) + ddot(n-k,a(k+1,k),1,z(k+1),1) - if (dabs(z(k)) .le. 1.0d0) go to 110 - s = 1.0d0/dabs(z(k)) - call dscal(n,s,z,1) - 110 continue - l = ipvt(k) - t = z(l) - z(l) = z(k) - z(k) = t - 120 continue - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) -c - ynorm = 1.0d0 -c -c solve l*v = y -c - do 140 k = 1, n - l = ipvt(k) - t = z(l) - z(l) = z(k) - z(k) = t - if (k .lt. n) call daxpy(n-k,t,a(k+1,k),1,z(k+1),1) - if (dabs(z(k)) .le. 1.0d0) go to 130 - s = 1.0d0/dabs(z(k)) - call dscal(n,s,z,1) - ynorm = s*ynorm - 130 continue - 140 continue - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) - ynorm = s*ynorm -c -c solve u*z = v -c - do 160 kb = 1, n - k = n + 1 - kb - if (dabs(z(k)) .le. dabs(a(k,k))) go to 150 - s = dabs(a(k,k))/dabs(z(k)) - call dscal(n,s,z,1) - ynorm = s*ynorm - 150 continue - if (a(k,k) .ne. 0.0d0) z(k) = z(k)/a(k,k) - if (a(k,k) .eq. 0.0d0) z(k) = 1.0d0 - t = -z(k) - call daxpy(k-1,t,a(1,k),1,z(1),1) - 160 continue -c make znorm = 1.0 - s = 1.0d0/dasum(n,z,1) - call dscal(n,s,z,1) - ynorm = s*ynorm -c - if (anorm .ne. 0.0d0) rcond = ynorm/anorm - if (anorm .eq. 0.0d0) rcond = 0.0d0 - return - end - - - subroutine dgedi(a,lda,n,ipvt,det,work,job) - integer lda,n,ipvt(1),job - double precision a(lda,1),det(2),work(1) -c -c dgedi computes the determinant and inverse of a matrix -c using the factors computed by dgeco or dgefa. -c -c on entry -c -c a double precision(lda, n) -c the output from dgeco or dgefa. -c -c lda integer -c the leading dimension of the array a . -c -c n integer -c the order of the matrix a . -c -c ipvt integer(n) -c the pivot vector from dgeco or dgefa. -c -c work double precision(n) -c work vector. contents destroyed. -c -c job integer -c = 11 both determinant and inverse. -c = 01 inverse only. -c = 10 determinant only. -c -c on return -c -c a inverse of original matrix if requested. -c otherwise unchanged. -c -c det double precision(2) -c determinant of original matrix if requested. -c otherwise not referenced. -c determinant = det(1) * 10.0**det(2) -c with 1.0 .le. dabs(det(1)) .lt. 10.0 -c or det(1) .eq. 0.0 . -c -c error condition -c -c a division by zero will occur if the input factor contains -c a zero on the diagonal and the inverse is requested. -c it will not occur if the subroutines are called correctly -c and if dgeco has set rcond .gt. 0.0 or dgefa has set -c info .eq. 0 . -c -c linpack. this version dated 08/14/78 . -c cleve moler, university of new mexico, argonne national lab. -c -c subroutines and functions -c -c blas daxpy,dscal,dswap -c fortran dabs,mod -c -c internal variables -c - double precision t - double precision ten - integer i,j,k,kb,kp1,l,nm1 -c -c -c compute determinant -c - if (job/10 .eq. 0) go to 70 - det(1) = 1.0d0 - det(2) = 0.0d0 - ten = 10.0d0 - do 50 i = 1, n - if (ipvt(i) .ne. i) det(1) = -det(1) - det(1) = a(i,i)*det(1) -c ...exit - if (det(1) .eq. 0.0d0) go to 60 - 10 if (dabs(det(1)) .ge. 1.0d0) go to 20 - det(1) = ten*det(1) - det(2) = det(2) - 1.0d0 - go to 10 - 20 continue - 30 if (dabs(det(1)) .lt. ten) go to 40 - det(1) = det(1)/ten - det(2) = det(2) + 1.0d0 - go to 30 - 40 continue - 50 continue - 60 continue - 70 continue -c -c compute inverse(u) -c - if (mod(job,10) .eq. 0) go to 150 - do 100 k = 1, n - a(k,k) = 1.0d0/a(k,k) - t = -a(k,k) - call dscal(k-1,t,a(1,k),1) - kp1 = k + 1 - if (n .lt. kp1) go to 90 - do 80 j = kp1, n - t = a(k,j) - a(k,j) = 0.0d0 - call daxpy(k,t,a(1,k),1,a(1,j),1) - 80 continue - 90 continue - 100 continue -c -c form inverse(u)*inverse(l) -c - nm1 = n - 1 - if (nm1 .lt. 1) go to 140 - do 130 kb = 1, nm1 - k = n - kb - kp1 = k + 1 - do 110 i = kp1, n - work(i) = a(i,k) - a(i,k) = 0.0d0 - 110 continue - do 120 j = kp1, n - t = work(j) - call daxpy(n,t,a(1,j),1,a(1,k),1) - 120 continue - l = ipvt(k) - if (l .ne. k) call dswap(n,a(1,k),1,a(1,l),1) - 130 continue - 140 continue - 150 continue - return - end - - diff --git a/ext/math/polfit.f b/ext/math/polfit.f deleted file mode 100644 index 08bdd98a2..000000000 --- a/ext/math/polfit.f +++ /dev/null @@ -1,289 +0,0 @@ -*DECK POLFIT - SUBROUTINE POLFIT (N, X, Y, W, MAXDEG, NDEG, EPS, R, IERR, A) -C***BEGIN PROLOGUE POLFIT -C***PURPOSE Fit discrete data in a least squares sense by polynomials -C in one variable. -C***LIBRARY SLATEC -C***CATEGORY K1A1A2 -C***TYPE SINGLE PRECISION (POLFIT-S, DPOLFT-D) -C***KEYWORDS CURVE FITTING, DATA FITTING, LEAST SQUARES, POLYNOMIAL FIT -C***AUTHOR Shampine, L. F., (SNLA) -C Davenport, S. M., (SNLA) -C Huddleston, R. E., (SNLL) -C***DESCRIPTION -C -C Abstract -C -C Given a collection of points X(I) and a set of values Y(I) which -C correspond to some function or measurement at each of the X(I), -C subroutine POLFIT computes the weighted least-squares polynomial -C fits of all degrees up to some degree either specified by the user -C or determined by the routine. The fits thus obtained are in -C orthogonal polynomial form. Subroutine PVALUE may then be -C called to evaluate the fitted polynomials and any of their -C derivatives at any point. The subroutine PCOEF may be used to -C express the polynomial fits as powers of (X-C) for any specified -C point C. -C -C The parameters for POLFIT are -C -C Input -- -C N - the number of data points. The arrays X, Y and W -C must be dimensioned at least N (N .GE. 1). -C X - array of values of the independent variable. These -C values may appear in any order and need not all be -C distinct. -C Y - array of corresponding function values. -C W - array of positive values to be used as weights. If -C W(1) is negative, POLFIT will set all the weights -C to 1.0, which means unweighted least squares error -C will be minimized. To minimize relative error, the -C user should set the weights to: W(I) = 1.0/Y(I)**2, -C I = 1,...,N . -C MAXDEG - maximum degree to be allowed for polynomial fit. -C MAXDEG may be any non-negative integer less than N. -C Note -- MAXDEG cannot be equal to N-1 when a -C statistical test is to be used for degree selection, -C i.e., when input value of EPS is negative. -C EPS - specifies the criterion to be used in determining -C the degree of fit to be computed. -C (1) If EPS is input negative, POLFIT chooses the -C degree based on a statistical F test of -C significance. One of three possible -C significance levels will be used: .01, .05 or -C .10. If EPS=-1.0 , the routine will -C automatically select one of these levels based -C on the number of data points and the maximum -C degree to be considered. If EPS is input as -C -.01, -.05, or -.10, a significance level of -C .01, .05, or .10, respectively, will be used. -C (2) If EPS is set to 0., POLFIT computes the -C polynomials of degrees 0 through MAXDEG . -C (3) If EPS is input positive, EPS is the RMS -C error tolerance which must be satisfied by the -C fitted polynomial. POLFIT will increase the -C degree of fit until this criterion is met or -C until the maximum degree is reached. -C -C Output -- -C NDEG - degree of the highest degree fit computed. -C EPS - RMS error of the polynomial of degree NDEG . -C R - vector of dimension at least NDEG containing values -C of the fit of degree NDEG at each of the X(I) . -C Except when the statistical test is used, these -C values are more accurate than results from subroutine -C PVALUE normally are. -C IERR - error flag with the following possible values. -C 1 -- indicates normal execution, i.e., either -C (1) the input value of EPS was negative, and the -C computed polynomial fit of degree NDEG -C satisfies the specified F test, or -C (2) the input value of EPS was 0., and the fits of -C all degrees up to MAXDEG are complete, or -C (3) the input value of EPS was positive, and the -C polynomial of degree NDEG satisfies the RMS -C error requirement. -C 2 -- invalid input parameter. At least one of the input -C parameters has an illegal value and must be corrected -C before POLFIT can proceed. Valid input results -C when the following restrictions are observed -C N .GE. 1 -C 0 .LE. MAXDEG .LE. N-1 for EPS .GE. 0. -C 0 .LE. MAXDEG .LE. N-2 for EPS .LT. 0. -C W(1)=-1.0 or W(I) .GT. 0., I=1,...,N . -C 3 -- cannot satisfy the RMS error requirement with a -C polynomial of degree no greater than MAXDEG . Best -C fit found is of degree MAXDEG . -C 4 -- cannot satisfy the test for significance using -C current value of MAXDEG . Statistically, the -C best fit found is of order NORD . (In this case, -C NDEG will have one of the values: MAXDEG-2, -C MAXDEG-1, or MAXDEG). Using a higher value of -C MAXDEG may result in passing the test. -C A - work and output array having at least 3N+3MAXDEG+3 -C locations -C -C Note - POLFIT calculates all fits of degrees up to and including -C NDEG . Any or all of these fits can be evaluated or -C expressed as powers of (X-C) using PVALUE and PCOEF -C after just one call to POLFIT . -C -C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, -C Curve fitting by polynomials in one variable, Report -C SLA-74-0270, Sandia Laboratories, June 1974. -C***ROUTINES CALLED PVALUE, XERMSG -C***REVISION HISTORY (YYMMDD) -C 740601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 920501 Reformatted the REFERENCES section. (WRB) -C 920527 Corrected erroneous statements in DESCRIPTION. (WRB) -C***END PROLOGUE POLFIT - DOUBLE PRECISION TEMD1,TEMD2 - DIMENSION X(*), Y(*), W(*), R(*), A(*) - -c DIMENSION CO(4,3) -c SAVE CO -c DATA CO(1,1), CO(2,1), CO(3,1), CO(4,1), CO(1,2), CO(2,2), -c 1 CO(3,2), CO(4,2), CO(1,3), CO(2,3), CO(3,3), -c 2 CO(4,3)/-13.086850,-2.4648165,-3.3846535,-1.2973162, -c 3 -3.3381146,-1.7812271,-3.2578406,-1.6589279, -c 4 -1.6282703,-1.3152745,-3.2640179,-1.9829776/ - -C***FIRST EXECUTABLE STATEMENT POLFIT - M = ABS(N) - IF (M .EQ. 0) GO TO 30 - IF (MAXDEG .LT. 0) GO TO 30 - A(1) = MAXDEG - MOP1 = MAXDEG + 1 - IF (M .LT. MOP1) GO TO 30 - IF (EPS .LT. 0.0 .AND. M .EQ. MOP1) GO TO 30 - - J = 0 -C -C SEE IF POLYNOMIAL OF DEGREE 0 SATISFIES THE DEGREE SELECTION CRITERION -C - IF (EPS) 24,26,27 -C -C INCREMENT DEGREE -C - 16 J = J + 1 - JP1 = J + 1 - K1PJ = K1 + J - K2PJ = K2 + J - SIGJM1 = SIGJ -C -C COMPUTE NEW B COEFFICIENT EXCEPT WHEN J = 1 -C - IF (J .GT. 1) A(K1PJ) = W11/W1 -C -C COMPUTE NEW A COEFFICIENT -C - TEMD1 = 0.0D0 - DO 18 I = 1,M - K4PI = K4 + I - TEMD2 = A(K4PI) - TEMD1 = TEMD1 + DBLE(X(I))*DBLE(W(I))*TEMD2*TEMD2 - 18 CONTINUE - A(JP1) = TEMD1/DBLE(W11) -C -C EVALUATE ORTHOGONAL POLYNOMIAL AT DATA POINTS -C - W1 = W11 - W11 = 0.0 - DO 19 I = 1,M - K3PI = K3 + I - K4PI = K4 + I - TEMP = A(K3PI) - A(K3PI) = A(K4PI) - A(K4PI) = (X(I)-A(JP1))*A(K3PI) - A(K1PJ)*TEMP - 19 W11 = W11 + W(I)*A(K4PI)**2 -C -C GET NEW ORTHOGONAL POLYNOMIAL COEFFICIENT USING PARTIAL DOUBLE -C PRECISION -C - TEMD1 = 0.0D0 - DO 20 I = 1,M - K4PI = K4 + I - K5PI = K5 + I - TEMD2 = DBLE(W(I))*DBLE((Y(I)-R(I))-A(K5PI))*DBLE(A(K4PI)) - 20 TEMD1 = TEMD1 + TEMD2 - TEMD1 = TEMD1/DBLE(W11) - A(K2PJ+1) = TEMD1 -C -C UPDATE POLYNOMIAL EVALUATIONS AT EACH OF THE DATA POINTS, AND -C ACCUMULATE SUM OF SQUARES OF ERRORS. THE POLYNOMIAL EVALUATIONS ARE -C COMPUTED AND STORED IN EXTENDED PRECISION. FOR THE I-TH DATA POINT, -C THE MOST SIGNIFICANT BITS ARE STORED IN R(I) , AND THE LEAST -C SIGNIFICANT BITS ARE IN A(K5PI) . -C - SIGJ = 0.0 - DO 21 I = 1,M - K4PI = K4 + I - K5PI = K5 + I - TEMD2 = DBLE(R(I)) + DBLE(A(K5PI)) + TEMD1*DBLE(A(K4PI)) - R(I) = TEMD2 - A(K5PI) = TEMD2 - DBLE(R(I)) - 21 SIGJ = SIGJ + W(I)*((Y(I)-R(I)) - A(K5PI))**2 -C -C SEE IF DEGREE SELECTION CRITERION HAS BEEN SATISFIED OR IF DEGREE -C MAXDEG HAS BEEN REACHED -C - IF (EPS) 23,26,27 -C -C COMPUTE F STATISTICS (INPUT EPS .LT. 0.) -C - 23 IF (SIGJ .EQ. 0.0) GO TO 29 -c DEGF = M - J - 1 -c DEN = (CO(4,KSIG)*DEGF + 1.0)*DEGF -c FCRIT = (((CO(3,KSIG)*DEGF) + CO(2,KSIG))*DEGF + CO(1,KSIG))/DEN -c FCRIT = FCRIT*FCRIT -c F = (SIGJM1 - SIGJ)*DEGF/SIGJ -c IF (F .LT. FCRIT) GO TO 25 - -C -C POLYNOMIAL OF DEGREE J SATISFIES F TEST -C - 24 SIGPAS = SIGJ - JPAS = J - NFAIL = 0 - IF (MAXDEG .EQ. J) GO TO 32 - GO TO 16 -C -C POLYNOMIAL OF DEGREE J FAILS F TEST. IF THERE HAVE BEEN THREE -C SUCCESSIVE FAILURES, A STATISTICALLY BEST DEGREE HAS BEEN FOUND. -C - 25 NFAIL = NFAIL + 1 - IF (NFAIL .GE. 3) GO TO 29 - IF (MAXDEG .EQ. J) GO TO 32 - GO TO 16 -C -C RAISE THE DEGREE IF DEGREE MAXDEG HAS NOT YET BEEN REACHED (INPUT -C EPS = 0.) -C - 26 IF (MAXDEG .EQ. J) GO TO 28 - GO TO 16 -C -C SEE IF RMS ERROR CRITERION IS SATISFIED (INPUT EPS .GT. 0.) -C - 27 IF (SIGJ .LE. ETST) GO TO 28 - IF (MAXDEG .EQ. J) GO TO 31 - GO TO 16 -C -C RETURNS -C - 28 IERR = 1 - NDEG = J - SIG = SIGJ - GO TO 33 - 29 IERR = 1 - NDEG = JPAS - SIG = SIGPAS - GO TO 33 - 30 IERR = 2 -c CALL XERMSG ('SLATEC', 'POLFIT', 'INVALID INPUT PARAMETER.', 2, -c + 1) - GO TO 37 - 31 IERR = 3 - NDEG = MAXDEG - SIG = SIGJ - GO TO 33 - 32 IERR = 4 - NDEG = JPAS - SIG = SIGPAS -C - 33 A(K3) = NDEG -C -C WHEN STATISTICAL TEST HAS BEEN USED, EVALUATE THE BEST POLYNOMIAL AT -C ALL THE DATA POINTS IF R DOES NOT ALREADY CONTAIN THESE VALUES -C - IF(EPS .GE. 0.0 .OR. NDEG .EQ. MAXDEG) GO TO 36 - NDER = 0 - DO 35 I = 1,M - CALL PVALUE (NDEG,NDER,X(I),R(I),YP,A) - 35 CONTINUE - 36 EPS = SQRT(SIG/XM) - 37 RETURN - END diff --git a/ext/math/printstring.c b/ext/math/printstring.c deleted file mode 100644 index fd6476ed7..000000000 --- a/ext/math/printstring.c +++ /dev/null @@ -1,11 +0,0 @@ -#include -#include "config.h" -#ifdef __cplusplus -extern "C" { -#endif -void printstring_(char* s, ftnlen ls) { - printf("%s",s); -} -#ifdef __cplusplus -} -#endif diff --git a/ext/math/pvalue.f b/ext/math/pvalue.f deleted file mode 100644 index 506a76ba6..000000000 --- a/ext/math/pvalue.f +++ /dev/null @@ -1,150 +0,0 @@ -*DECK PVALUE - SUBROUTINE PVALUE (L, NDER, X, YFIT, YP, A) -C***BEGIN PROLOGUE PVALUE -C***PURPOSE Use the coefficients generated by POLFIT to evaluate the -C polynomial fit of degree L, along with the first NDER of -C its derivatives, at a specified point. -C***LIBRARY SLATEC -C***CATEGORY K6 -C***TYPE SINGLE PRECISION (PVALUE-S, DP1VLU-D) -C***KEYWORDS CURVE FITTING, LEAST SQUARES, POLYNOMIAL APPROXIMATION -C***AUTHOR Shampine, L. F., (SNLA) -C Davenport, S. M., (SNLA) -C***DESCRIPTION -C -C Written by L. F. Shampine and S. M. Davenport. -C -C Abstract -C -C The subroutine PVALUE uses the coefficients generated by POLFIT -C to evaluate the polynomial fit of degree L , along with the first -C NDER of its derivatives, at a specified point. Computationally -C stable recurrence relations are used to perform this task. -C -C The parameters for PVALUE are -C -C Input -- -C L - the degree of polynomial to be evaluated. L may be -C any non-negative integer which is less than or equal -C to NDEG , the highest degree polynomial provided -C by POLFIT . -C NDER - the number of derivatives to be evaluated. NDER -C may be 0 or any positive value. If NDER is less -C than 0, it will be treated as 0. -C X - the argument at which the polynomial and its -C derivatives are to be evaluated. -C A - work and output array containing values from last -C call to POLFIT . -C -C Output -- -C YFIT - value of the fitting polynomial of degree L at X -C YP - array containing the first through NDER derivatives -C of the polynomial of degree L . YP must be -C dimensioned at least NDER in the calling program. -C -C***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, -C Curve fitting by polynomials in one variable, Report -C SLA-74-0270, Sandia Laboratories, June 1974. -C***ROUTINES CALLED XERMSG -C***REVISION HISTORY (YYMMDD) -C 740601 DATE WRITTEN -C 890531 Changed all specific intrinsics to generic. (WRB) -C 890531 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) -C 900510 Convert XERRWV calls to XERMSG calls. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE PVALUE - DIMENSION YP(*),A(*) - CHARACTER*8 XERN1, XERN2 -C***FIRST EXECUTABLE STATEMENT PVALUE - IF (L .LT. 0) GO TO 12 - NDO = MAX(NDER,0) - NDO = MIN(NDO,L) - MAXORD = A(1) + 0.5 - K1 = MAXORD + 1 - K2 = K1 + MAXORD - K3 = K2 + MAXORD + 2 - NORD = A(K3) + 0.5 - IF (L .GT. NORD) GO TO 11 - K4 = K3 + L + 1 - IF (NDER .LT. 1) GO TO 2 - DO 1 I = 1,NDER - 1 YP(I) = 0.0 - 2 IF (L .GE. 2) GO TO 4 - IF (L .EQ. 1) GO TO 3 -C -C L IS 0 -C - VAL = A(K2+1) - GO TO 10 -C -C L IS 1 -C - 3 CC = A(K2+2) - VAL = A(K2+1) + (X-A(2))*CC - IF (NDER .GE. 1) YP(1) = CC - GO TO 10 -C -C L IS GREATER THAN 1 -C - 4 NDP1 = NDO + 1 - K3P1 = K3 + 1 - K4P1 = K4 + 1 - LP1 = L + 1 - LM1 = L - 1 - ILO = K3 + 3 - IUP = K4 + NDP1 - DO 5 I = ILO,IUP - 5 A(I) = 0.0 - DIF = X - A(LP1) - KC = K2 + LP1 - A(K4P1) = A(KC) - A(K3P1) = A(KC-1) + DIF*A(K4P1) - A(K3+2) = A(K4P1) -C -C EVALUATE RECURRENCE RELATIONS FOR FUNCTION VALUE AND DERIVATIVES -C - DO 9 I = 1,LM1 - IN = L - I - INP1 = IN + 1 - K1I = K1 + INP1 - IC = K2 + IN - DIF = X - A(INP1) - VAL = A(IC) + DIF*A(K3P1) - A(K1I)*A(K4P1) - IF (NDO .LE. 0) GO TO 8 - DO 6 N = 1,NDO - K3PN = K3P1 + N - K4PN = K4P1 + N - 6 YP(N) = DIF*A(K3PN) + N*A(K3PN-1) - A(K1I)*A(K4PN) -C -C SAVE VALUES NEEDED FOR NEXT EVALUATION OF RECURRENCE RELATIONS -C - DO 7 N = 1,NDO - K3PN = K3P1 + N - K4PN = K4P1 + N - A(K4PN) = A(K3PN) - 7 A(K3PN) = YP(N) - 8 A(K4P1) = A(K3P1) - 9 A(K3P1) = VAL -C -C NORMAL RETURN OR ABORT DUE TO ERROR -C - 10 YFIT = VAL - RETURN -C - 11 return -cWRITE (XERN1, '(I8)') L -c WRITE (XERN2, '(I8)') NORD -c CALL XERMSG ('SLATEC', 'PVALUE', -c * 'THE ORDER OF POLYNOMIAL EVALUATION, L = ' // XERN1 // -c * ' REQUESTED EXCEEDS THE HIGHEST ORDER FIT, NORD = ' // XERN2 // -c * ', COMPUTED BY POLFIT -- EXECUTION TERMINATED.', 8, 2) -c RETURN -C - 12 return -c CALL XERMSG ('SLATEC', 'PVALUE', -c + 'INVALID INPUT PARAMETER. ORDER OF POLYNOMIAL EVALUATION ' // -c + 'REQUESTED IS NEGATIVE -- EXECUTION TERMINATED.', 2, 2) -c RETURN - END diff --git a/ext/math/xercnt.f b/ext/math/xercnt.f deleted file mode 100644 index 06c82ab18..000000000 --- a/ext/math/xercnt.f +++ /dev/null @@ -1,60 +0,0 @@ -*DECK XERCNT - SUBROUTINE XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL) -C***BEGIN PROLOGUE XERCNT -C***SUBSIDIARY -C***PURPOSE Allow user control over handling of errors. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERCNT-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C Allows user control over handling of individual errors. -C Just after each message is recorded, but before it is -C processed any further (i.e., before it is printed or -C a decision to abort is made), a call is made to XERCNT. -C If the user has provided his own version of XERCNT, he -C can then override the value of KONTROL used in processing -C this message by redefining its value. -C KONTRL may be set to any value from -2 to 2. -C The meanings for KONTRL are the same as in XSETF, except -C that the value of KONTRL changes only for this message. -C If KONTRL is set to a value outside the range from -2 to 2, -C it will be moved back into that range. -C -C Description of Parameters -C -C --Input-- -C LIBRAR - the library that the routine is in. -C SUBROU - the subroutine that XERMSG is being called from -C MESSG - the first 20 characters of the error message. -C NERR - same as in the call to XERMSG. -C LEVEL - same as in the call to XERMSG. -C KONTRL - the current value of the control flag as set -C by a call to XSETF. -C -C --Output-- -C KONTRL - the new value of KONTRL. If KONTRL is not -C defined, it will remain at its original value. -C This changed value of control affects only -C the current occurrence of the current message. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900206 Routine changed from user-callable to subsidiary. (WRB) -C 900510 Changed calling sequence to include LIBRARY and SUBROUTINE -C names, changed routine name from XERCTL to XERCNT. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERCNT - CHARACTER*(*) LIBRAR, SUBROU, MESSG -C***FIRST EXECUTABLE STATEMENT XERCNT - RETURN - END diff --git a/ext/math/xerhlt.f b/ext/math/xerhlt.f deleted file mode 100644 index 052092940..000000000 --- a/ext/math/xerhlt.f +++ /dev/null @@ -1,40 +0,0 @@ -*DECK XERHLT - SUBROUTINE XERHLT (MESSG) -C***BEGIN PROLOGUE XERHLT -C***SUBSIDIARY -C***PURPOSE Abort program execution and print error message. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERHLT-A) -C***KEYWORDS ABORT PROGRAM EXECUTION, ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C ***Note*** machine dependent routine -C XERHLT aborts the execution of the program. -C The error message causing the abort is given in the calling -C sequence, in case one needs it for printing on a dayfile, -C for example. -C -C Description of Parameters -C MESSG is as in XERMSG. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED (NONE) -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900206 Routine changed from user-callable to subsidiary. (WRB) -C 900510 Changed calling sequence to delete length of character -C and changed routine name from XERABT to XERHLT. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERHLT - CHARACTER*(*) MESSG -C***FIRST EXECUTABLE STATEMENT XERHLT - write(*,*) 'stopping...' - STOP - END diff --git a/ext/math/xermsg.f b/ext/math/xermsg.f deleted file mode 100644 index 46c83ec07..000000000 --- a/ext/math/xermsg.f +++ /dev/null @@ -1,364 +0,0 @@ -*DECK XERMSG - SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL) -C***BEGIN PROLOGUE XERMSG -C***PURPOSE Process error messages for SLATEC and other libraries. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERMSG-A) -C***KEYWORDS ERROR MESSAGE, XERROR -C***AUTHOR Fong, Kirby, (NMFECC at LLNL) -C***DESCRIPTION -C -C XERMSG processes a diagnostic message in a manner determined by the -C value of LEVEL and the current value of the library error control -C flag, KONTRL. See subroutine XSETF for details. -C -C LIBRAR A character constant (or character variable) with the name -C of the library. This will be 'SLATEC' for the SLATEC -C Common Math Library. The error handling package is -C general enough to be used by many libraries -C simultaneously, so it is desirable for the routine that -C detects and reports an error to identify the library name -C as well as the routine name. -C -C SUBROU A character constant (or character variable) with the name -C of the routine that detected the error. Usually it is the -C name of the routine that is calling XERMSG. There are -C some instances where a user callable library routine calls -C lower level subsidiary routines where the error is -C detected. In such cases it may be more informative to -C supply the name of the routine the user called rather than -C the name of the subsidiary routine that detected the -C error. -C -C MESSG A character constant (or character variable) with the text -C of the error or warning message. In the example below, -C the message is a character constant that contains a -C generic message. -C -C CALL XERMSG ('SLATEC', 'MMPY', -C *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION', -C *3, 1) -C -C It is possible (and is sometimes desirable) to generate a -C specific message--e.g., one that contains actual numeric -C values. Specific numeric values can be converted into -C character strings using formatted WRITE statements into -C character variables. This is called standard Fortran -C internal file I/O and is exemplified in the first three -C lines of the following example. You can also catenate -C substrings of characters to construct the error message. -C Here is an example showing the use of both writing to -C an internal file and catenating character strings. -C -C CHARACTER*5 CHARN, CHARL -C WRITE (CHARN,10) N -C WRITE (CHARL,10) LDA -C 10 FORMAT(I5) -C CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN// -C * ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'// -C * CHARL, 3, 1) -C -C There are two subtleties worth mentioning. One is that -C the // for character catenation is used to construct the -C error message so that no single character constant is -C continued to the next line. This avoids confusion as to -C whether there are trailing blanks at the end of the line. -C The second is that by catenating the parts of the message -C as an actual argument rather than encoding the entire -C message into one large character variable, we avoid -C having to know how long the message will be in order to -C declare an adequate length for that large character -C variable. XERMSG calls XERPRN to print the message using -C multiple lines if necessary. If the message is very long, -C XERPRN will break it into pieces of 72 characters (as -C requested by XERMSG) for printing on multiple lines. -C Also, XERMSG asks XERPRN to prefix each line with ' * ' -C so that the total line length could be 76 characters. -C Note also that XERPRN scans the error message backwards -C to ignore trailing blanks. Another feature is that -C the substring '$$' is treated as a new line sentinel -C by XERPRN. If you want to construct a multiline -C message without having to count out multiples of 72 -C characters, just use '$$' as a separator. '$$' -C obviously must occur within 72 characters of the -C start of each line to have its intended effect since -C XERPRN is asked to wrap around at 72 characters in -C addition to looking for '$$'. -C -C NERR An integer value that is chosen by the library routine's -C author. It must be in the range -99 to 999 (three -C printable digits). Each distinct error should have its -C own error number. These error numbers should be described -C in the machine readable documentation for the routine. -C The error numbers need be unique only within each routine, -C so it is reasonable for each routine to start enumerating -C errors from 1 and proceeding to the next integer. -C -C LEVEL An integer value in the range 0 to 2 that indicates the -C level (severity) of the error. Their meanings are -C -C -1 A warning message. This is used if it is not clear -C that there really is an error, but the user's attention -C may be needed. An attempt is made to only print this -C message once. -C -C 0 A warning message. This is used if it is not clear -C that there really is an error, but the user's attention -C may be needed. -C -C 1 A recoverable error. This is used even if the error is -C so serious that the routine cannot return any useful -C answer. If the user has told the error package to -C return after recoverable errors, then XERMSG will -C return to the Library routine which can then return to -C the user's routine. The user may also permit the error -C package to terminate the program upon encountering a -C recoverable error. -C -C 2 A fatal error. XERMSG will not return to its caller -C after it receives a fatal error. This level should -C hardly ever be used; it is much better to allow the -C user a chance to recover. An example of one of the few -C cases in which it is permissible to declare a level 2 -C error is a reverse communication Library routine that -C is likely to be called repeatedly until it integrates -C across some interval. If there is a serious error in -C the input such that another step cannot be taken and -C the Library routine is called again without the input -C error having been corrected by the caller, the Library -C routine will probably be called forever with improper -C input. In this case, it is reasonable to declare the -C error to be fatal. -C -C Each of the arguments to XERMSG is input; none will be modified by -C XERMSG. A routine may make multiple calls to XERMSG with warning -C level messages; however, after a call to XERMSG with a recoverable -C error, the routine should return to the user. Do not try to call -C XERMSG with a second recoverable error after the first recoverable -C error because the error package saves the error number. The user -C can retrieve this error number by calling another entry point in -C the error handling package and then clear the error number when -C recovering from the error. Calling XERMSG in succession causes the -C old error number to be overwritten by the latest error number. -C This is considered harmless for error numbers associated with -C warning messages but must not be done for error numbers of serious -C errors. After a call to XERMSG with a recoverable error, the user -C must be given a chance to call NUMXER or XERCLR to retrieve or -C clear the error number. -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE -C***REVISION HISTORY (YYMMDD) -C 880101 DATE WRITTEN -C 880621 REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988. -C THERE ARE TWO BASIC CHANGES. -C 1. A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO -C PRINT MESSAGES. THIS ROUTINE WILL BREAK LONG MESSAGES -C INTO PIECES FOR PRINTING ON MULTIPLE LINES. '$$' IS -C ACCEPTED AS A NEW LINE SENTINEL. A PREFIX CAN BE -C ADDED TO EACH LINE TO BE PRINTED. XERMSG USES EITHER -C ' ***' OR ' * ' AND LONG MESSAGES ARE BROKEN EVERY -C 72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE -C LENGTH OUTPUT CAN NOW BE AS GREAT AS 76. -C 2. THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE -C FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE -C OF LOWER CASE. -C 880708 REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30. -C THE PRINCIPAL CHANGES ARE -C 1. CLARIFY COMMENTS IN THE PROLOGUES -C 2. RENAME XRPRNT TO XERPRN -C 3. REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES -C SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE / -C CHARACTER FOR NEW RECORDS. -C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO -C CLEAN UP THE CODING. -C 890721 REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN -C PREFIX. -C 891013 REVISED TO CORRECT COMMENTS. -C 891214 Prologue converted to Version 4.0 format. (WRB) -C 900510 Changed test on NERR to be -9999999 < NERR < 99999999, but -C NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3. Added -C LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and -C XERCTL to XERCNT. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERMSG - CHARACTER*(*) LIBRAR, SUBROU, MESSG - CHARACTER*8 XLIBR, XSUBR - CHARACTER*72 TEMP - CHARACTER*20 LFIRST -C***FIRST EXECUTABLE STATEMENT XERMSG - LKNTRL = J4SAVE (2, 0, .FALSE.) - MAXMES = J4SAVE (4, 0, .FALSE.) -C -C LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL. -C MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE -C SHOULD BE PRINTED. -C -C WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN -C CALLING XERMSG. THE ERROR NUMBER SHOULD BE POSITIVE, -C AND THE LEVEL SHOULD BE BETWEEN 0 AND 2. -C - IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR. - * LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN - CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // - * 'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// - * 'JOB ABORT DUE TO FATAL ERROR.', 72) - CALL XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY) - CALL XERHLT (' ***XERMSG -- INVALID INPUT') - RETURN - ENDIF -C -C RECORD THE MESSAGE. -C - I = J4SAVE (1, NERR, .TRUE.) - CALL XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT) -C -C HANDLE PRINT-ONCE WARNING MESSAGES. -C - IF (LEVEL.EQ.-1 .AND. KOUNT.GT.1) RETURN -C -C ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG. -C - XLIBR = LIBRAR - XSUBR = SUBROU - LFIRST = MESSG - LERR = NERR - LLEVEL = LEVEL - CALL XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL) -C - LKNTRL = MAX(-2, MIN(2,LKNTRL)) - MKNTRL = ABS(LKNTRL) -C -C SKIP PRINTING IF THE CONTROL FLAG VALUE AS RESET IN XERCNT IS -C ZERO AND THE ERROR IS NOT FATAL. -C - IF (LEVEL.LT.2 .AND. LKNTRL.EQ.0) GO TO 30 - IF (LEVEL.EQ.0 .AND. KOUNT.GT.MAXMES) GO TO 30 - IF (LEVEL.EQ.1 .AND. KOUNT.GT.MAXMES .AND. MKNTRL.EQ.1) GO TO 30 - IF (LEVEL.EQ.2 .AND. KOUNT.GT.MAX(1,MAXMES)) GO TO 30 -C -C ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A -C MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS) -C AND SENDING IT OUT VIA XERPRN. PRINT ONLY IF CONTROL FLAG -C IS NOT ZERO. -C - IF (LKNTRL .NE. 0) THEN - TEMP(1:21) = 'MESSAGE FROM ROUTINE ' - I = MIN(LEN(SUBROU), 16) - TEMP(22:21+I) = SUBROU(1:I) - TEMP(22+I:33+I) = ' IN LIBRARY ' - LTEMP = 33 + I - I = MIN(LEN(LIBRAR), 16) - TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I) - TEMP(LTEMP+I+1:LTEMP+I+1) = '.' - LTEMP = LTEMP + I + 1 - CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) - ENDIF -C -C IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE -C PRINTING THE MESSAGE. THE INTRODUCTORY LINE TELLS THE CHOICE -C FROM EACH OF THE FOLLOWING THREE OPTIONS. -C 1. LEVEL OF THE MESSAGE -C 'INFORMATIVE MESSAGE' -C 'POTENTIALLY RECOVERABLE ERROR' -C 'FATAL ERROR' -C 2. WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE -C 'PROG CONTINUES' -C 'PROG ABORTED' -C 3. WHETHER OR NOT A TRACEBACK WAS REQUESTED. (THE TRACEBACK -C MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS -C WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.) -C 'TRACEBACK REQUESTED' -C 'TRACEBACK NOT REQUESTED' -C NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT -C EXCEED 74 CHARACTERS. -C WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED. -C - IF (LKNTRL .GT. 0) THEN -C -C THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL. -C - IF (LEVEL .LE. 0) THEN - TEMP(1:20) = 'INFORMATIVE MESSAGE,' - LTEMP = 20 - ELSEIF (LEVEL .EQ. 1) THEN - TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,' - LTEMP = 30 - ELSE - TEMP(1:12) = 'FATAL ERROR,' - LTEMP = 12 - ENDIF -C -C THEN WHETHER THE PROGRAM WILL CONTINUE. -C - IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR. - * (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN - TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,' - LTEMP = LTEMP + 14 - ELSE - TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,' - LTEMP = LTEMP + 16 - ENDIF -C -C FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK. -C - IF (LKNTRL .GT. 0) THEN - TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED' - LTEMP = LTEMP + 20 - ELSE - TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED' - LTEMP = LTEMP + 24 - ENDIF - CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72) - ENDIF -C -C NOW SEND OUT THE MESSAGE. -C - CALL XERPRN (' * ', -1, MESSG, 72) -C -C IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A -C TRACEBACK. -C - IF (LKNTRL .GT. 0) THEN - WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR - DO 10 I=16,22 - IF (TEMP(I:I) .NE. ' ') GO TO 20 - 10 CONTINUE -C - 20 CALL XERPRN (' * ', -1, TEMP(1:15) // TEMP(I:23), 72) - CALL FDUMP - ENDIF -C -C IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE. -C - IF (LKNTRL .NE. 0) THEN - CALL XERPRN (' * ', -1, ' ', 72) - CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72) - CALL XERPRN (' ', 0, ' ', 72) - ENDIF -C -C IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE -C CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN. -C - 30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN -C -C THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A -C FATAL ERROR. PRINT THE REASON FOR THE ABORT AND THE ERROR -C SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT. -C - IF (LKNTRL.GT.0 .AND. KOUNT.LT.MAX(1,MAXMES)) THEN - IF (LEVEL .EQ. 1) THEN - CALL XERPRN - * (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72) - ELSE - CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72) - ENDIF - CALL XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY) - CALL XERHLT (' ') - ELSE - CALL XERHLT (MESSG) - ENDIF - RETURN - END diff --git a/ext/math/xerprn.f b/ext/math/xerprn.f deleted file mode 100644 index 24099ce47..000000000 --- a/ext/math/xerprn.f +++ /dev/null @@ -1,230 +0,0 @@ -*DECK XERPRN - SUBROUTINE XERPRN (PREFIX, NPREF, MESSG, NWRAP) -C***BEGIN PROLOGUE XERPRN -C***SUBSIDIARY -C***PURPOSE Print error messages processed by XERMSG. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XERPRN-A) -C***KEYWORDS ERROR MESSAGES, PRINTING, XERROR -C***AUTHOR Fong, Kirby, (NMFECC at LLNL) -C***DESCRIPTION -C -C This routine sends one or more lines to each of the (up to five) -C logical units to which error messages are to be sent. This routine -C is called several times by XERMSG, sometimes with a single line to -C print and sometimes with a (potentially very long) message that may -C wrap around into multiple lines. -C -C PREFIX Input argument of type CHARACTER. This argument contains -C characters to be put at the beginning of each line before -C the body of the message. No more than 16 characters of -C PREFIX will be used. -C -C NPREF Input argument of type INTEGER. This argument is the number -C of characters to use from PREFIX. If it is negative, the -C intrinsic function LEN is used to determine its length. If -C it is zero, PREFIX is not used. If it exceeds 16 or if -C LEN(PREFIX) exceeds 16, only the first 16 characters will be -C used. If NPREF is positive and the length of PREFIX is less -C than NPREF, a copy of PREFIX extended with blanks to length -C NPREF will be used. -C -C MESSG Input argument of type CHARACTER. This is the text of a -C message to be printed. If it is a long message, it will be -C broken into pieces for printing on multiple lines. Each line -C will start with the appropriate prefix and be followed by a -C piece of the message. NWRAP is the number of characters per -C piece; that is, after each NWRAP characters, we break and -C start a new line. In addition the characters '$$' embedded -C in MESSG are a sentinel for a new line. The counting of -C characters up to NWRAP starts over for each new line. The -C value of NWRAP typically used by XERMSG is 72 since many -C older error messages in the SLATEC Library are laid out to -C rely on wrap-around every 72 characters. -C -C NWRAP Input argument of type INTEGER. This gives the maximum size -C piece into which to break MESSG for printing on multiple -C lines. An embedded '$$' ends a line, and the count restarts -C at the following character. If a line break does not occur -C on a blank (it would split a word) that word is moved to the -C next line. Values of NWRAP less than 16 will be treated as -C 16. Values of NWRAP greater than 132 will be treated as 132. -C The actual line length will be NPREF + NWRAP after NPREF has -C been adjusted to fall between 0 and 16 and NWRAP has been -C adjusted to fall between 16 and 132. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED I1MACH, XGETUA -C***REVISION HISTORY (YYMMDD) -C 880621 DATE WRITTEN -C 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF -C JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK -C THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE -C SLASH CHARACTER IN FORMAT STATEMENTS. -C 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO -C STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK -C LINES TO BE PRINTED. -C 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF -C CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. -C 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. -C 891214 Prologue converted to Version 4.0 format. (WRB) -C 900510 Added code to break messages between words. (RWC) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERPRN - CHARACTER*(*) PREFIX, MESSG - INTEGER NPREF, NWRAP - CHARACTER*148 CBUFF - INTEGER IU(5), NUNIT - CHARACTER*2 NEWLIN - PARAMETER (NEWLIN = '$$') -C***FIRST EXECUTABLE STATEMENT XERPRN - CALL XGETUA(IU,NUNIT) -C -C A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD -C ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD -C ERROR MESSAGE UNIT. -C - N = I1MACH(4) - DO 10 I=1,NUNIT - IF (IU(I) .EQ. 0) IU(I) = N - 10 CONTINUE -C -C LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE -C BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING -C THE REST OF THIS ROUTINE. -C - IF ( NPREF .LT. 0 ) THEN - LPREF = LEN(PREFIX) - ELSE - LPREF = NPREF - ENDIF - LPREF = MIN(16, LPREF) - IF (LPREF .NE. 0) CBUFF(1:LPREF) = PREFIX -C -C LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE -C TIME FROM MESSG TO PRINT ON ONE LINE. -C - LWRAP = MAX(16, MIN(132, NWRAP)) -C -C SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. -C - LENMSG = LEN(MESSG) - N = LENMSG - DO 20 I=1,N - IF (MESSG(LENMSG:LENMSG) .NE. ' ') GO TO 30 - LENMSG = LENMSG - 1 - 20 CONTINUE - 30 CONTINUE -C -C IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. -C - IF (LENMSG .EQ. 0) THEN - CBUFF(LPREF+1:LPREF+1) = ' ' - call printstring(cbuff) -c DO 40 I=1,NUNIT -c WRITE(IU(I), '(A)') CBUFF(1:LPREF+1) -c 40 CONTINUE - RETURN - ENDIF -C -C SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING -C STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. -C WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. -C WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. -C -C WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE -C INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE -C OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH -C OF THE SECOND ARGUMENT. -C -C THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE -C FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER -C OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT -C POSITION NEXTC. -C -C LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE -C REMAINDER OF THE CHARACTER STRING. LPIECE -C SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, -C WHICHEVER IS LESS. -C -C LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: -C NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE -C PRINT NOTHING TO AVOID PRODUCING UNNECESSARY -C BLANK LINES. THIS TAKES CARE OF THE SITUATION -C WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF -C EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE -C SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC -C SHOULD BE INCREMENTED BY 2. -C -C LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. -C -C ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 -C RESET LPIECE = LPIECE-1. NOTE THAT THIS -C PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. -C LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY -C AT THE END OF A LINE. -C - NEXTC = 1 - 50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN) - IF (LPIECE .EQ. 0) THEN -C -C THERE WAS NO NEW LINE SENTINEL FOUND. -C - IDELTA = 0 - LPIECE = MIN(LWRAP, LENMSG+1-NEXTC) - IF (LPIECE .LT. LENMSG+1-NEXTC) THEN - DO 52 I=LPIECE+1,2,-1 - IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN - LPIECE = I-1 - IDELTA = 1 - GOTO 54 - ENDIF - 52 CONTINUE - ENDIF - 54 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + IDELTA - ELSEIF (LPIECE .EQ. 1) THEN -C -C WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). -C DON'T PRINT A BLANK LINE. -C - NEXTC = NEXTC + 2 - GO TO 50 - ELSEIF (LPIECE .GT. LWRAP+1) THEN -C -C LPIECE SHOULD BE SET DOWN TO LWRAP. -C - IDELTA = 0 - LPIECE = LWRAP - DO 56 I=LPIECE+1,2,-1 - IF (MESSG(NEXTC+I-1:NEXTC+I-1) .EQ. ' ') THEN - LPIECE = I-1 - IDELTA = 1 - GOTO 58 - ENDIF - 56 CONTINUE - 58 CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + IDELTA - ELSE -C -C IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. -C WE SHOULD DECREMENT LPIECE BY ONE. -C - LPIECE = LPIECE - 1 - CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1) - NEXTC = NEXTC + LPIECE + 2 - ENDIF -C -C PRINT -C - call printstring(cbuff) -c DO 60 I=1,NUNIT -c WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE) -c 60 CONTINUE -C - IF (NEXTC .LE. LENMSG) GO TO 50 - RETURN - END diff --git a/ext/math/xersve.f b/ext/math/xersve.f deleted file mode 100644 index 6bd2a4f7a..000000000 --- a/ext/math/xersve.f +++ /dev/null @@ -1,155 +0,0 @@ -*DECK XERSVE - SUBROUTINE XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, - + ICOUNT) -C***BEGIN PROLOGUE XERSVE -C***SUBSIDIARY -C***PURPOSE Record that an error has occurred. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3 -C***TYPE ALL (XERSVE-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C *Usage: -C -C INTEGER KFLAG, NERR, LEVEL, ICOUNT -C CHARACTER * (len) LIBRAR, SUBROU, MESSG -C -C CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) -C -C *Arguments: -C -C LIBRAR :IN is the library that the message is from. -C SUBROU :IN is the subroutine that the message is from. -C MESSG :IN is the message to be saved. -C KFLAG :IN indicates the action to be performed. -C when KFLAG > 0, the message in MESSG is saved. -C when KFLAG=0 the tables will be dumped and -C cleared. -C when KFLAG < 0, the tables will be dumped and -C not cleared. -C NERR :IN is the error number. -C LEVEL :IN is the error severity. -C ICOUNT :OUT the number of times this message has been seen, -C or zero if the table has overflowed and does not -C contain this message specifically. When KFLAG=0, -C ICOUNT will not be altered. -C -C *Description: -C -C Record that this error occurred and possibly dump and clear the -C tables. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED I1MACH, XGETUA -C***REVISION HISTORY (YYMMDD) -C 800319 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 900413 Routine modified to remove reference to KFLAG. (WRB) -C 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling -C sequence, use IF-THEN-ELSE, make number of saved entries -C easily changeable, changed routine name from XERSAV to -C XERSVE. (RWC) -C 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XERSVE - PARAMETER (LENTAB=10) - INTEGER LUN(5) - CHARACTER*(*) LIBRAR, SUBROU, MESSG - CHARACTER*8 LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB - CHARACTER*20 MESTAB(LENTAB), MES - DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB) - SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG - DATA KOUNTX/0/, NMSG/0/ -C***FIRST EXECUTABLE STATEMENT XERSVE -C - IF (KFLAG.LE.0) THEN -C -C Dump the table. -C - IF (NMSG.EQ.0) RETURN -C -C Print to each unit. -C - CALL XGETUA (LUN, NUNIT) - DO 20 KUNIT = 1,NUNIT - IUNIT = LUN(KUNIT) - IF (IUNIT.EQ.0) IUNIT = I1MACH(4) -C -C Print the table header. -C - WRITE (IUNIT,9000) -C -C Print body of table. -C - DO 10 I = 1,NMSG - WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), - * NERTAB(I),LEVTAB(I),KOUNT(I) - 10 CONTINUE -C -C Print number of other errors. -C - IF (KOUNTX.NE.0) WRITE (IUNIT,9020) KOUNTX - WRITE (IUNIT,9030) - 20 CONTINUE -C -C Clear the error tables. -C - IF (KFLAG.EQ.0) THEN - NMSG = 0 - KOUNTX = 0 - ENDIF - ELSE -C -C PROCESS A MESSAGE... -C SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, -C OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. -C - LIB = LIBRAR - SUB = SUBROU - MES = MESSG - DO 30 I = 1,NMSG - IF (LIB.EQ.LIBTAB(I) .AND. SUB.EQ.SUBTAB(I) .AND. - * MES.EQ.MESTAB(I) .AND. NERR.EQ.NERTAB(I) .AND. - * LEVEL.EQ.LEVTAB(I)) THEN - KOUNT(I) = KOUNT(I) + 1 - ICOUNT = KOUNT(I) - RETURN - ENDIF - 30 CONTINUE -C - IF (NMSG.LT.LENTAB) THEN -C -C Empty slot found for new message. -C - NMSG = NMSG + 1 - LIBTAB(I) = LIB - SUBTAB(I) = SUB - MESTAB(I) = MES - NERTAB(I) = NERR - LEVTAB(I) = LEVEL - KOUNT (I) = 1 - ICOUNT = 1 - ELSE -C -C Table is full. -C - KOUNTX = KOUNTX+1 - ICOUNT = 0 - ENDIF - ENDIF - RETURN -C -C Formats. -C - 9000 FORMAT ('0 ERROR MESSAGE SUMMARY' / - + ' LIBRARY SUBROUTINE MESSAGE START NERR', - + ' LEVEL COUNT') - 9010 FORMAT (1X,A,3X,A,3X,A,3I10) - 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10) - 9030 FORMAT (1X) - END diff --git a/ext/math/xgetua.f b/ext/math/xgetua.f deleted file mode 100644 index 2e7db0212..000000000 --- a/ext/math/xgetua.f +++ /dev/null @@ -1,51 +0,0 @@ -*DECK XGETUA - SUBROUTINE XGETUA (IUNITA, N) -C***BEGIN PROLOGUE XGETUA -C***PURPOSE Return unit number(s) to which error messages are being -C sent. -C***LIBRARY SLATEC (XERROR) -C***CATEGORY R3C -C***TYPE ALL (XGETUA-A) -C***KEYWORDS ERROR, XERROR -C***AUTHOR Jones, R. E., (SNLA) -C***DESCRIPTION -C -C Abstract -C XGETUA may be called to determine the unit number or numbers -C to which error messages are being sent. -C These unit numbers may have been set by a call to XSETUN, -C or a call to XSETUA, or may be a default value. -C -C Description of Parameters -C --Output-- -C IUNIT - an array of one to five unit numbers, depending -C on the value of N. A value of zero refers to the -C default unit, as defined by the I1MACH machine -C constant routine. Only IUNIT(1),...,IUNIT(N) are -C defined by XGETUA. The values of IUNIT(N+1),..., -C IUNIT(5) are not defined (for N .LT. 5) or altered -C in any way by XGETUA. -C N - the number of units to which copies of the -C error messages are being sent. N will be in the -C range from 1 to 5. -C -C***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC -C Error-handling Package, SAND82-0800, Sandia -C Laboratories, 1982. -C***ROUTINES CALLED J4SAVE -C***REVISION HISTORY (YYMMDD) -C 790801 DATE WRITTEN -C 861211 REVISION DATE from Version 3.2 -C 891214 Prologue converted to Version 4.0 format. (BAB) -C 920501 Reformatted the REFERENCES section. (WRB) -C***END PROLOGUE XGETUA - DIMENSION IUNITA(5) -C***FIRST EXECUTABLE STATEMENT XGETUA - N = J4SAVE(5,0,.FALSE.) - DO 30 I=1,N - INDEX = I+4 - IF (I.EQ.1) INDEX = 3 - IUNITA(I) = J4SAVE(INDEX,0,.FALSE.) - 30 CONTINUE - RETURN - END